XML-Validator-Schema-1.10/ 0000755 0000764 0000764 00000000000 10750441441 013346 5 ustar sam sam XML-Validator-Schema-1.10/t/ 0000755 0000764 0000764 00000000000 10750441441 013611 5 ustar sam sam XML-Validator-Schema-1.10/t/all.yml 0000644 0000764 0000764 00000001422 07736372140 015114 0 ustar sam sam # simple all test
--- |
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL
--- |
--- >
FAIL
--- |
--- >
FAIL
XML-Validator-Schema-1.10/t/content_message.yml 0000644 0000764 0000764 00000000653 10142472217 017516 0 ustar sam sam # test the error message for content-model failures
--- |
--- |
--- >
FAIL /Contents of element 'A'/
--- |
--- >
FAIL /Inside element 'A'/
XML-Validator-Schema-1.10/t/attribute_types2.yml 0000644 0000764 0000764 00000001162 10253732673 017655 0 ustar sam sam # test attribute types bug report
--- |
--- |
--- >
PASS
--- |
--- >
FAIL
--- |
--- >
PASS
XML-Validator-Schema-1.10/t/bad_type_length.yml 0000644 0000764 0000764 00000000741 10140257204 017461 0 ustar sam sam # test disallowed facet types and values
# only 1 test per file, as first test will always fail the whole file when the schema is parsed
--- |
--- |
1
--- >
FAIL /nonNegativeInteger/
XML-Validator-Schema-1.10/t/union_test_inline.yml 0000644 0000764 0000764 00000004051 10747667031 020074 0 ustar sam sam # Test correct behaviour on unions with a good schema
# This defines a union using inline simpleTypes. This syntax isn't
# described in http://www.w3schools.com/schema/el_union.asp but it is
# presumably contained somewhere in the formal definitions and is
# recognised by other validators. In any case we've been using this format
# extensively for some time.
--- |
#########################################################################
Union test
#########################################################################
--- |
union test pass
99999
TBA
--- >
PASS
--- |
union test fail 1
xyz
--- >
FAIL
XML-Validator-Schema-1.10/t/attribute_ref.yml 0000644 0000764 0000764 00000001605 07737327310 017206 0 ustar sam sam # test a simple schema that uses attribute refs
--- |
--- |
bar
--- >
PASS
--- |
bar
--- >
FAIL /[iI]llegal value/
--- |
bar
--- >
FAIL /[mM]issing required/
XML-Validator-Schema-1.10/t/min_exclusive.yml 0000644 0000764 0000764 00000000562 10072566563 017223 0 ustar sam sam --- |
--- |
-49
--- >
PASS
--- |
-50
--- >
FAIL
XML-Validator-Schema-1.10/t/element_ref.yml 0000644 0000764 0000764 00000001641 07737175004 016635 0 ustar sam sam # test a simple schema that allows multiple root elements and uses refs
--- |
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL
XML-Validator-Schema-1.10/t/complex_attr.yml 0000644 0000764 0000764 00000001156 10071035324 017033 0 ustar sam sam --- |
--- |
12345678
Title
--- >
PASS
XML-Validator-Schema-1.10/t/union_test_ref.yml 0000644 0000764 0000764 00000003341 10747667031 017373 0 ustar sam sam # Test correct behaviour on unions with a good schema (with refs)
--- |
#########################################################################
Union test
#########################################################################
--- |
union test pass
99999
TBA
--- >
PASS
--- |
union test fail 1
xyz
--- >
FAIL
XML-Validator-Schema-1.10/t/restriction.yml 0000644 0000764 0000764 00000011301 07737065024 016707 0 ustar sam sam # test some simpletype restrictions
--- |
--- |
aaaaabbbbcccc
--- >
PASS
--- |
aaaaabbbbccccZZZZ
--- >
FAIL
--- |
aaaaabbbbccccZZZZ
--- >
FAIL
--- |
--- >
FAIL
--- |
p
q
--- >
PASS
--- |
z
--- >
FAIL /[iI]llegal value/
--- |
true
false
--- >
FAIL /[iI]llegal value/
--- |
1
0
--- >
PASS
--- |
0123456789
--- >
PASS
--- |
01234567891
--- >
FAIL /[iI]llegal value/
--- |
012345678
--- >
FAIL /[iI]llegal value/
--- |
01
--- >
FAIL /[iI]llegal value/
--- |
012
--- >
PASS
--- |
0123
--- >
PASS
--- |
01234
--- >
PASS
--- |
012345
--- >
FAIL /[iI]llegal value/
--- |
0123456789
--- >
PASS
--- |
01 345 789
--- >
PASS
--- |
0123456789
--- >
PASS
--- |
01234567891
--- >
FAIL /[iI]llegal value/
--- |
012345678
--- >
FAIL /[iI]llegal value/
--- |
foo(012345678)
--- >
PASS
--- |
bar[TENTHENTEN]
--- >
PASS
--- |
foo(10)bar[TENTHENTEN]
--- >
FAIL /[iI]llegal value/
--- |
0123456789
--- >
PASS
--- |
012 45 78
--- >
PASS
--- |
12 45 78
--- >
PASS
--- |
0123456789
--- >
FAIL /[iI]llegal value/
XML-Validator-Schema-1.10/t/substring.yml 0000644 0000764 0000764 00000004663 10071036511 016357 0 ustar sam sam # Test an where one element name is a substring of another.
# This comes from a bug report which I couldn't replicate.
--- |
--- |
0x0
0x0
--- >
PASS
--- |
0x0
0x0
--- >
PASS
--- |
0x0
0x0
--- >
FAIL
--- |
0x0
0x0
0x0
--- >
FAIL
XML-Validator-Schema-1.10/t/elementrefintype.yml 0000644 0000764 0000764 00000001776 10041541526 017724 0 ustar sam sam --- |
--- |
--- >
FAIL
--- |
--- >
PASS
XML-Validator-Schema-1.10/t/07locator.t 0000644 0000764 0000764 00000002176 10205155261 015613 0 ustar sam sam #!/usr/bin/perl
use strict;
use warnings;
use Test::More qw(no_plan);
use_ok('XML::Validator::Schema') or exit;
use XML::SAX::ParserFactory;
$XML::SAX::ParserPackage = 'XML::SAX::ExpatXS';
# test requires XML::SAX::ExpatXS and XML::Filter::ExceptionLocator
eval { require XML::SAX::ExpatXS };
my $has_expatxs = $@ ? 0 : 1;
eval { require XML::Filter::ExceptionLocator };
my $has_el = $@ ? 0 : 1;
SKIP: {
skip 'These tests require XML::SAX::ExpatXS', 1 unless $has_expatxs;
skip 'These tests require XML::Filter::ExceptionLocator', 1 unless $has_el;
my $v = XML::Validator::Schema->new(file => 't/test.xsd');
ok($v);
my $p = XML::SAX::ParserFactory->parser(Handler => $v);
ok($p);
# parse a file with an error on line 6
eval { $p->parse_uri('t/bad.xml') };
isa_ok($@, 'XML::SAX::Exception');
is($@->{LineNumber}, 6);
ok($@->{ColumnNumber} >= 11);
like($@, qr/\[Ln: 6/);
# now a bad XSD
eval { $v = XML::Validator::Schema->new(file => 't/bad.xsd') };
isa_ok($@, 'XML::SAX::Exception');
is($@->{LineNumber}, 4);
ok($@->{ColumnNumber} >= 6);
like($@, qr/\[Ln: 4/);
};
XML-Validator-Schema-1.10/t/choice.yml 0000644 0000764 0000764 00000001174 10142472217 015571 0 ustar sam sam # simple choice test
--- |
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL /'that' does not match/
--- |
--- >
FAIL
XML-Validator-Schema-1.10/t/simple_content.yml 0000644 0000764 0000764 00000002140 07737175004 017366 0 ustar sam sam # test elements with simpleContent and attributes
--- |
--- |
10
-1000
--- >
PASS
--- |
aaa
-1000
--- >
FAIL /[iI]llegal value/
--- |
10
-1000
--- >
FAIL /[mM]issing required/
XML-Validator-Schema-1.10/t/02yaml.t 0000644 0000764 0000764 00000000542 07736353372 015122 0 ustar sam sam #!/usr/bin/perl
use strict;
use warnings;
use lib 't/lib';
use Test::More qw(no_plan);
use TestRunner qw(test_yml foreach_parser);
foreach_parser {
if ($ENV{TEST_YML}) {
test_yml($ENV{TEST_YML});
} else {
for (sort glob('t/*.yml')) {
print "\n######## $_ #######\n";
test_yml($_);
}
}
};
XML-Validator-Schema-1.10/t/03types.t 0000644 0000764 0000764 00000020337 10747666713 015333 0 ustar sam sam #!/usr/bin/perl
use strict;
use warnings;
use Test::More qw(no_plan);
use XML::Validator::Schema::TypeLibrary;
my $lib = XML::Validator::Schema::TypeLibrary->new();
sub supported_type {
return 1 if $lib->find(name => shift);
return 0;
}
our $LAST_MSG;
sub check_type {
my $type = $lib->find(name => shift);
return 0 unless $type;
my ($ok, $msg) = $type->check(shift);
$LAST_MSG = $msg;
return $ok;
}
ok(supported_type('string'));
ok(check_type(string => "any ol' thang"));
ok(check_type(string => ""));
ok(supported_type('integer'));
ok(check_type(integer => "0"));
ok(check_type(integer => "1"));
ok(check_type(integer => "-1"));
ok(check_type(integer => "2147483647"));
ok(check_type(integer => "-2147483648"));
ok(check_type(integer => "12147483648"));
ok(check_type(integer => "-12147483648"));
ok(supported_type('nonPositiveInteger'));
ok( check_type(nonPositiveInteger => "0"));
ok(not check_type(nonPositiveInteger => "1"));
ok( check_type(nonPositiveInteger => "-1"));
ok(not check_type(nonPositiveInteger => "2147483647"));
ok( check_type(nonPositiveInteger => "-2147483648"));
ok(not check_type(nonPositiveInteger => "12147483648"));
ok( check_type(nonPositiveInteger => "-12147483648"));
ok(supported_type('nonNegativeInteger'));
ok( check_type(nonNegativeInteger => "0"));
ok( check_type(nonNegativeInteger => "1"));
ok(not check_type(nonNegativeInteger => "-1"));
ok( check_type(nonNegativeInteger => "2147483647"));
ok(not check_type(nonNegativeInteger => "-2147483648"));
ok( check_type(nonNegativeInteger => "12147483648"));
ok(not check_type(nonNegativeInteger => "-12147483648"));
ok(supported_type('positiveInteger'));
ok(not check_type(positiveInteger => "0"));
ok( check_type(positiveInteger => "1"));
ok(not check_type(positiveInteger => "-1"));
ok( check_type(positiveInteger => "2147483647"));
ok(not check_type(positiveInteger => "-2147483648"));
ok( check_type(positiveInteger => "12147483648"));
ok(not check_type(positiveInteger => "-12147483648"));
ok(supported_type('negativeInteger'));
ok(not check_type(negativeInteger => "0"));
ok(not check_type(negativeInteger => "1"));
ok( check_type(negativeInteger => "-1"));
ok(not check_type(negativeInteger => "2147483647"));
ok( check_type(negativeInteger => "-2147483648"));
ok(not check_type(negativeInteger => "12147483648"));
ok( check_type(negativeInteger => "-12147483648"));
ok(supported_type('int'));
ok(check_type(int => "1"));
ok(check_type(int => "-1"));
ok(check_type(int => "2147483647"));
ok(check_type(int => "-2147483648"));
ok(not check_type(int => "12147483648"));
ok(not check_type(int => "-12147483648"));
ok(supported_type('unsignedInt'));
ok(check_type(unsignedInt => "1"));
ok(not check_type(unsignedInt => "-1"));
ok(check_type(unsignedInt => "2147483647"));
ok(not check_type(unsignedInt => "-2147483648"));
ok(not check_type(unsignedInt => "12147483648"));
ok(not check_type(unsignedInt => "-12147483648"));
ok(supported_type('short'));
ok(check_type(short => "1"));
ok(check_type(short => "-1"));
ok(not check_type(short => "2147483647"));
ok(not check_type(short => "-2147483648"));
ok(supported_type('unsignedShort'));
ok(check_type(unsignedShort => "1"));
ok(not check_type(unsignedShort => "-1"));
ok(not check_type(unsignedShort => "2147483647"));
ok(not check_type(unsignedShort => "-2147483648"));
ok(supported_type('byte'));
ok(check_type(byte => "1"));
ok(check_type(byte => "-1"));
ok(not check_type(byte => "255"));
ok(not check_type(byte => "-255"));
ok(supported_type('unsignedByte'));
ok(check_type(unsignedByte => "1"));
ok(not check_type(unsignedByte => "-1"));
ok(check_type(unsignedByte => "255"));
ok(not check_type(unsignedByte => "-255"));
ok(supported_type('boolean'));
ok(check_type(boolean => "0"));
ok(check_type(boolean => "1"));
ok(check_type(boolean => "true"));
ok(check_type(boolean => "false"));
ok(not check_type(boolean => "foo"));
ok(supported_type('dateTime'));
ok(check_type(dateTime => "1999-05-31T13:20:00-05:00"));
ok(check_type(dateTime => "1999-05-31T13:20:00+05:00"));
ok(check_type(dateTime => "1999-05-31T13:20:00"));
ok(check_type(dateTime => "1999-05-31T13:20:00Z"));
ok(check_type(dateTime => "-1999-05-31T13:20:00Z"));
ok(check_type(dateTime => "+1999-05-31T13:20:00Z"));
ok(not check_type(dateTime => "99-05-31T13:20:00-05:00"));
ok(supported_type('NMTOKEN'));
ok(check_type(NMTOKEN => ""));
ok(check_type(NMTOKEN => "sam"));
ok(check_type(NMTOKEN => "123sam.-_:"));
ok(not check_type(NMTOKEN => "123sam.-_:!"));
ok(supported_type('normalizedString'));
ok(check_type(normalizedString => ""));
ok(check_type(normalizedString => "sam"));
ok(check_type(normalizedString => "\n\ns\na\nm\n\n"));
ok(supported_type('token'));
ok(check_type(normalizedString => ""));
ok(check_type(normalizedString => "sam"));
ok(check_type(normalizedString => "\n\ns\na\nm\n\n"));
ok(supported_type('double'));
ok(check_type(double => '-1E4'));
ok(check_type(double => '1267.43233E12'));
ok(check_type(double => '12.78e-2'));
ok(check_type(double => '12'));
ok(check_type(double => '012'));
ok(check_type(double => 'INF'));
ok(not check_type(double => 'A'));
ok(not check_type(double => 'b10.5'));
ok(not check_type(double => ''));
ok(supported_type('QName'));
ok(check_type(QName =>'pre:myElement'));
ok(check_type(QName =>'myElement'));
ok(check_type(QName =>'a123:b3212'));
ok(check_type(QName =>'b3212'));
ok(not check_type(QName =>':myElement'));
ok(not check_type(QName =>'pre:3myElement'));
ok(supported_type('base64Binary'));
ok(check_type(base64Binary => '1968'));
ok(check_type(base64Binary => '0FB8'));
ok(check_type(base64Binary => '0fb8'));
ok(check_type(base64Binary => '0F'));
ok(check_type(base64Binary => 'FFFF00'));
ok(check_type(base64Binary => 'FFZq09'));
ok(check_type(base64Binary => 'F+Zq09'));
ok(supported_type('date'));
ok(check_type(date => '1968-04-02'));
ok(check_type(date => '-0045-01-01'));
ok(check_type(date => '11968-04-02'));
ok(check_type(date => '1968-04-02+05:00'));
ok(check_type(date => '1968-04-02Z'));
ok(not check_type(date => '68-04-02'));
ok(not check_type(date => '1968-4-2'));
ok(not check_type(date => '1968/04/02'));
ok(not check_type(date => '04-02-1968'));
ok(not check_type(date => '1968-04-31'));
ok(supported_type('gDay'));
ok(check_type(gDay => '---02'));
ok(check_type(gDay => '---02-05:00'));
ok(check_type(gDay => '---02Z'));
ok(not check_type(gDay => '02'));
ok(not check_type(gDay => '---2'));
ok(not check_type(gDay => '---32'));
ok(supported_type('gMonth'));
ok(check_type(gMonth => '--04'));
ok(check_type(gMonth => '--04-05:00'));
ok(check_type(gMonth => '--04Z'));
ok(not check_type(gMonth => '04'));
ok(not check_type(gMonth => '--4'));
ok(not check_type(gMonth => '--13'));
ok(supported_type('gMonthDay'));
ok(check_type(gMonthDay => '--04-02'));
ok(check_type(gMonthDay => '--04-02-05:00'));
ok(check_type(gMonthDay => '--04-12Z'));
ok(not check_type(gMonthDay => '--4-12Z'));
ok(not check_type(gMonthDay => '--4-12'));
ok(not check_type(gMonthDay => '--04-12+26:00'));
ok(supported_type('gYear'));
ok(check_type(gYear => '1968'));
ok(check_type(gYear => '1968-05:00'));
ok(check_type(gYear => '11968'));
ok(check_type(gYear => '0968'));
ok(check_type(gYear => '-0045'));
ok(not check_type(gYear => '68'));
ok(not check_type(gYear => '968'));
ok(not check_type(gYear => '1968-25:00'));
ok(supported_type('gYearMonth'));
ok(check_type(gYearMonth => '1968-04'));
ok(check_type(gYearMonth => '1968-04-05:00'));
ok(check_type(gYearMonth => '1968-12Z'));
ok(not check_type(gYearMonth => '68-04'));
ok(not check_type(gYearMonth => '1968'));
ok(not check_type(gYearMonth => '1968-4'));
ok(not check_type(gYearMonth => '1968-13'));
ok(supported_type('hexBinary'));
ok(check_type(hexBinary => '1968'));
ok(check_type(hexBinary => '0FB8'));
ok(check_type(hexBinary => '0fb8'));
ok(check_type(hexBinary => '0F'));
ok(check_type(hexBinary => 'FFFF00'));
ok(not check_type(hexBinary => 'FB8'));
ok(supported_type('time'));
ok(check_type(time => '13:30:59'));
ok(check_type(time => '13:20:30.5555'));
ok(check_type(time => '13:20:30-05:00'));
ok(check_type(time => '13:20:30Z'));
ok(not check_type(time => '5:20:30'));
ok(not check_type(time => '05:0:30'));
ok(not check_type(time => '05:20:3'));
ok(not check_type(time => '05:20:'));
ok(not check_type(time => '05:20.5:30'));
ok(not check_type(time => '05:65:30'));
XML-Validator-Schema-1.10/t/digits.yml 0000644 0000764 0000764 00000002425 10747671114 015632 0 ustar sam sam # test a decimal with totalDigits and FractionDigits restrictions
--- |
--- |
12345
--- >
PASS
--- |
-12345
--- >
PASS
--- |
123.45
--- >
PASS
--- |
123.450
--- >
PASS
--- |
123.4500000
--- >
PASS
--- |
00000123.45
--- >
PASS
--- |
00000123.4500000
--- >
PASS
--- |
-123.45
--- >
PASS
--- |
12.345
--- >
FAIL
--- |
123456
--- >
FAIL
--- |
123.456
--- >
FAIL
--- |
456
--- >
PASS
--- |
456.0
--- >
PASS
--- |
0456.00
--- >
PASS
--- |
00456
--- >
PASS
--- |
0.45
--- >
PASS
--- |
.45
--- >
PASS
--- |
--- >
FAIL
XML-Validator-Schema-1.10/t/test.xml 0000644 0000764 0000764 00000000247 07737440702 015327 0 ustar sam sam
1
1
foo
...
true
1977-08-02T20:02:00
XML-Validator-Schema-1.10/t/global_type.yml 0000644 0000764 0000764 00000001525 07736372140 016651 0 ustar sam sam # two_level.yml - a simple schema with one level of children, both optional
--- |
--- |
--- >
PASS
--- |
--- >
FAIL /unexpected /
--- |
--- >
PASS
--- |
--- >
FAIL /does not match/
XML-Validator-Schema-1.10/t/bad_type_totalDigits.yml 0000644 0000764 0000764 00000000773 10140257204 020474 0 ustar sam sam # test disallowed facet types and values
# only 1 test per file, as first test will always fail the whole file when the schema is parsed
--- |
--- |
1
--- >
FAIL /positiveInteger/
XML-Validator-Schema-1.10/t/two_level.yml 0000644 0000764 0000764 00000001475 10142472217 016343 0 ustar sam sam # two_level.yml - a simple schema with one level of children, both optional
--- |
--- |
--- >
PASS
--- |
--- >
FAIL /unexpected /
--- |
--- >
PASS
--- |
--- >
FAIL /'bar' does not match content model/
XML-Validator-Schema-1.10/t/restricted_integer.yml 0000644 0000764 0000764 00000000752 07736660524 020244 0 ustar sam sam # test an integer restricted to within -2 and 5
--- |
--- |
3
--- >
PASS
--- |
-3
--- >
FAIL
--- |
-2
--- >
PASS
--- |
5
--- >
FAIL
XML-Validator-Schema-1.10/t/ora_book_1.yml.todo 0000644 0000764 0000764 00000006464 07737327310 017336 0 ustar sam sam # the first example schema from the O'Reilly XML Schema book, slightly
# modified to not use date and language types
--- |
--- |
0836217462
Being a Dog Is a Full-Time Job
Charles M Schulz
1922-11-26
2000-02-12
Peppermint Patty
1966-08-22
bold, brash and tomboyish
Snoopy
1950-10-04
extroverted beagle
Schroeder
1951-05-30
brought classical music to the Peanuts strip
Lucy
1952-03-03
bossy, crabby and selfish
--- >
PASS
XML-Validator-Schema-1.10/t/restriction_anon.yml 0000644 0000764 0000764 00000001451 07736660524 017734 0 ustar sam sam # test some simpletype restrictions, done as anonymous simple types
--- |
--- |
aaaaabbbbcccc
--- >
PASS
--- |
aaaaabbbbccccZZZZ
--- >
FAIL
--- |
--- >
FAIL
XML-Validator-Schema-1.10/t/complex_attr2.yml 0000644 0000764 0000764 00000001335 10120376627 017125 0 ustar sam sam --- |
--- |
--- >
PASS
--- |
--- >
FAIL
XML-Validator-Schema-1.10/t/05xerces.t 0000644 0000764 0000764 00000001512 07740324556 015447 0 ustar sam sam #!/usr/bin/perl
use strict;
use warnings;
# use Xerces/C++ to verify that the .yml tests are correct. Requires
# the XERCES_DOMCOUNT environment variable to be correctly set to the
# location of a working copy of the DOMCount example program from the
# Xerces/C++ source.
BEGIN {
unless ($ENV{XERCES_DOMCOUNT}) {
eval "use Test::More skip_all => 'Test requires \$XERCES_DOMCOUNT';";
} else {
eval "use Test::More qw(no_plan);";
}
}
use lib 't/lib';
use TestRunner qw(test_yml_xerces);
if ($ENV{TEST_YML}) {
test_yml_xerces($ENV{TEST_YML});
} else {
# skip tests Xerces doesn't like
for (sort grep { $_ ne 't/qualified.yml' and
$_ ne 't/repeated_groups.yml'
} glob('t/*.yml')) {
print "\n######## $_ #######\n";
test_yml_xerces($_);
}
}
XML-Validator-Schema-1.10/t/group.yml.todo 0000644 0000764 0000764 00000002074 07740325312 016442 0 ustar sam sam # test the first group example from the XML Schema tutorial
--- |
--- |
foo
1,2,3
--- >
PASS
--- |
foo
foo
1,2,3
--- >
PASS
--- |
foo
foo
foo
1,2,3
--- >
FAIL
--- |
1,2,3
--- >
FAIL
XML-Validator-Schema-1.10/t/repeated_groups.yml 0000644 0000764 0000764 00000006154 10142472217 017532 0 ustar sam sam # sequence with repetion
--- |
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL
--- |
--- >
PASS
--- |
--- >
FAIL
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL
--- |
--- >
FAIL /'zero_or_one-2' does not match/
--- |
--- >
PASS
XML-Validator-Schema-1.10/t/bad.xsd 0000644 0000764 0000764 00000001215 10205155261 015053 0 ustar sam sam
XML-Validator-Schema-1.10/t/recursive.yml 0000644 0000764 0000764 00000002031 10041541513 016331 0 ustar sam sam # test a schema with a recursive definition
--- |
--- |
foo
bar
--- >
PASS
--- |
foo
bar
bar
bar
--- >
PASS
XML-Validator-Schema-1.10/t/bad.xml 0000644 0000764 0000764 00000000247 10142535572 015070 0 ustar sam sam
1
1
foo
...
zool
1977-08-02T20:02:00
XML-Validator-Schema-1.10/t/simple_recursion.yml 0000644 0000764 0000764 00000000677 07736372140 017741 0 ustar sam sam # make sure my example from my use.perl journal really works ;)
--- |
--- |
--- >
PASS
XML-Validator-Schema-1.10/t/sequence.yml 0000644 0000764 0000764 00000002012 10142472217 016137 0 ustar sam sam # two_level.yml - a more complex sequence
--- |
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL
--- |
--- >
FAIL /'zero_or_one-2' does not match/
XML-Validator-Schema-1.10/t/bad_restriction.yml 0000644 0000764 0000764 00000000625 07736660524 017531 0 ustar sam sam # test an attempt to restrict along an unsupported facet
--- |
--- |
aaaaabbbbcccc
--- >
FAIL /illegal restriction/
XML-Validator-Schema-1.10/t/foo.yml 0000644 0000764 0000764 00000000674 07736372140 015137 0 ustar sam sam # foo.yml - test a simple schema that allows only a single root
# element called foo
--- |
--- |
--- >
PASS
--- |
--- >
FAIL /unexpected /
--- |
--- >
FAIL /unexpected /
XML-Validator-Schema-1.10/t/min2max2.yml 0000644 0000764 0000764 00000001121 10037606506 015767 0 ustar sam sam --- |
--- |
--- >
FAIL
--- |
--- >
PASS
--- |
--- >
FAIL
XML-Validator-Schema-1.10/t/bad_constraint_minLength-less-than-equal-to-maxLength.yml 0000644 0000764 0000764 00000001271 10140257203 026674 0 ustar sam sam # test invalid Schema Component Constraints
# only 1 test per file, as first test will always fail the whole file when the schema is parsed
--- |
--- |
ab
--- >
FAIL /is greater than than facet /
XML-Validator-Schema-1.10/t/bad_type_maxLength.yml 0000644 0000764 0000764 00000000763 10140257204 020133 0 ustar sam sam # test disallowed facet types and values
# only 1 test per file, as first test will always fail the whole file when the schema is parsed
--- |
--- |
1
--- >
FAIL /nonNegativeInteger/
XML-Validator-Schema-1.10/t/multi_level.yml 0000644 0000764 0000764 00000002233 07736372140 016666 0 ustar sam sam # multi_level.yml - a simple schema with some depth
--- |
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL /does not match/
XML-Validator-Schema-1.10/t/plankton_orig.yml 0000644 0000764 0000764 00000007103 07740325106 017207 0 ustar sam sam # plankton's example from Perlmonks.
# http://perlmonks.org/index.pl?node_id=295416
--- |
--- |
A1112CD
Metaphorical Web
James Eldridge
MetWeb
Semantic Web
Sarah Tremaine
SemanticWeb
Essay on Metaphorical
Web
1
Article
155.60
155.60
Lesson Package
4
Lesson
176.13
704.52
860.12
--- >
PASS
XML-Validator-Schema-1.10/t/country.yml 0000644 0000764 0000764 00000001527 10072566544 016055 0 ustar sam sam # an enumerated attribute
--- |
--- |
--- >
FAIL /not in allowed list/
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL /not in allowed list/
XML-Validator-Schema-1.10/t/test.xsd 0000644 0000764 0000764 00000001215 07737440702 015321 0 ustar sam sam
XML-Validator-Schema-1.10/t/bad_constraint_length-minLength-maxLength.yml 0000644 0000764 0000764 00000001236 10140257203 024533 0 ustar sam sam # test invalid Schema Component Constraints
# only 1 test per file, as first test will always fail the whole file when the schema is parsed
--- |
--- |
ab
--- >
FAIL /Facet is defined in addition to facets or /
XML-Validator-Schema-1.10/t/media.yml 0000644 0000764 0000764 00000006500 07734661233 015427 0 ustar sam sam # test against a real-world schema used on a CMS project
--- |
Comment describing your root element
must name a file inside the kds archive
--- |
151
Image
Lorelei Dangle Blurs
affluent.png
media_151/affluent.png
264
superscripted.kra/affluent.png
1
2003-06-09T00:00:00
--- >
PASS
--- |
151
Image
Lorelei Dangle Blurs
affluent.png
media_151/affluent.png
264
superscripted.kra/affluent.png
1
2003-06-09T00:00:00
--- >
PASS
XML-Validator-Schema-1.10/t/bad_constraint_fractionDigits-totalDigits.yml 0000644 0000764 0000764 00000001202 10140257203 024631 0 ustar sam sam # test invalid Schema Component Constraints
# only 1 test per file, as first test will always fail the whole file when the schema is parsed
--- |
--- |
12
--- >
FAIL /is greater than facet /
XML-Validator-Schema-1.10/t/multiroot.yml 0000644 0000764 0000764 00000000767 07737175004 016416 0 ustar sam sam # test a simple schema that allows multiple root elements
--- |
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL /unexpected /
--- |
--- >
FAIL /unexpected /
XML-Validator-Schema-1.10/t/attribute_types.yml 0000644 0000764 0000764 00000002440 10205211532 017552 0 ustar sam sam # test attribute types
--- |
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL /[Ii]llegal value/
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL /[Ii]llegal value/
XML-Validator-Schema-1.10/t/element_type.yml 0000644 0000764 0000764 00000002300 07736372140 017032 0 ustar sam sam # test element types
--- |
--- |
--- >
PASS
--- |
1
1
foo
...
true
1977-08-02T20:02:00
--- >
PASS
--- |
what are you looking at?
--- >
FAIL /[Ii]llegal value/
--- |
foo!!!
1
1
foo
...
true
1977-08-02T20:02:00
--- >
FAIL
XML-Validator-Schema-1.10/t/qualified.yml 0000644 0000764 0000764 00000000361 07736372140 016310 0 ustar sam sam # test bad attribute type
--- |
--- |
--- >
FAIL /not.*?supported/
XML-Validator-Schema-1.10/t/04model.t 0000644 0000764 0000764 00000011055 10142472217 015244 0 ustar sam sam #!/usr/bin/perl
use strict;
use warnings;
use Test::More qw(no_plan);
use XML::Validator::Schema;
use XML::Validator::Schema::ElementNode;
use XML::Validator::Schema::ModelNode;
# create test elements
my $foo = XML::Validator::Schema::ElementNode->parse(
{ Attributes => { '{}name' => { Value => 'foo' } } });
my $bar = XML::Validator::Schema::ElementNode->parse(
{ Attributes => { '{}name' => { Value => 'bar' } } });
my $baz = XML::Validator::Schema::ElementNode->parse(
{ Attributes => { '{}name' => { Value => 'baz' } } });
# foo contains a sequence of (bar, baz)
my $sequence = XML::Validator::Schema::ModelNode->parse({ LocalName => 'sequence' });
$foo->add_daughter($sequence);
$sequence->add_daughters($bar, $baz);
is($sequence->daughters(), 2);
# compile sequence into $foo
$sequence->compile();
is($foo->daughters, 2);
is(($foo->daughters())[0]->name, $bar->name);
is(($foo->daughters())[1]->name, $baz->name);
isa_ok($foo->{model}, 'XML::Validator::Schema::ModelNode');
# check the description
is($foo->{model}->{description}, "(bar,baz)");
# check a sequence of nodes against the model
eval { $foo->{model}->check_final_model('', ['bar', 'baz']) };
is($@, "");
eval { $foo->{model}->check_model('', ['bar']) };
is($@, "");
eval { $foo->{model}->check_final_model('', []) };
like($@, qr/do not match content model/);
eval { $foo->{model}->check_model('', ['baz']) };
like($@, qr/does not match content model/);
# foo contains a choice of (bar|baz)
my $choice = XML::Validator::Schema::ModelNode->parse({ LocalName => 'choice' });
$foo->clear_daughters();
$foo->{model} = undef;
$foo->add_daughter($choice);
$choice->add_daughters($baz, $bar);
is($choice->daughters(), 2);
# compile model into $foo
$choice->compile();
is($foo->daughters, 2);
is(($foo->daughters())[0]->name, $baz->name);
is(($foo->daughters())[1]->name, $bar->name);
isa_ok($foo->{model}, 'XML::Validator::Schema::ModelNode');
# check the description
is($foo->{model}->{description}, "(baz|bar)");
# check a sequence of nodes against the model
eval { $foo->{model}->check_final_model('', ['bar']) };
is($@, "");
eval { $foo->{model}->check_model('', ['baz']) };
is($@, "");
eval { $foo->{model}->check_final_model('', []) };
like($@, qr/do not match content model/);
eval { $foo->{model}->check_model('', ['bar', 'baz']) };
like($@, qr/does not match content model/);
# foo contains an 'all' of (bar&baz)
my $all = XML::Validator::Schema::ModelNode->parse({ LocalName => 'all' });
$foo->clear_daughters();
$foo->{model} = undef;
$foo->add_daughter($all);
$all->add_daughters($bar, $baz);
is($all->daughters(), 2);
# compile model into $foo
$all->compile();
is($foo->daughters, 2);
is(($foo->daughters())[0]->name, $bar->name);
is(($foo->daughters())[1]->name, $baz->name);
isa_ok($foo->{model}, 'XML::Validator::Schema::ModelNode');
# check the description
is($foo->{model}->{description}, "(bar&baz)");
# check a sequence of nodes against the model
eval { $foo->{model}->check_final_model('', ['bar', 'baz']) };
is($@, "");
eval { $foo->{model}->check_final_model('', ['baz', 'bar']) };
is($@, "");
eval { $foo->{model}->check_final_model('', []) };
like($@, qr/do not match content model/);
my $bang = XML::Validator::Schema::ElementNode->parse(
{ Attributes => { '{}name' => { Value => 'bang' } } });
my $bop = XML::Validator::Schema::ElementNode->parse(
{ Attributes => { '{}name' => { Value => 'bop' } } });
# foo contains a sequence with a choice of (bar,(bang|bop),baz)
$sequence = XML::Validator::Schema::ModelNode->parse({ LocalName => 'sequence' });
$foo->clear_daughters();
$foo->{model} = undef;
$foo->add_daughter($sequence);
$choice = XML::Validator::Schema::ModelNode->parse({ LocalName => 'choice' });
$choice->add_daughters($bang, $bop);
$sequence->add_daughters($bar, $choice, $baz);
is($sequence->daughters(), 3);
# compile sequence into $foo
$sequence->compile();
# all daughters should end up in $foo
is($foo->daughters, 4);
# check the description
is($foo->{model}->{description}, "(bar,(bang|bop),baz)");
# check a sequence of nodes against the model
eval { $foo->{model}->check_final_model('', ['bar', 'bang', 'baz']) };
is($@, "");
eval { $foo->{model}->check_final_model('', ['bar', 'bop', 'baz']) };
is($@, "");
eval { $foo->{model}->check_model('', ['bar']) };
is($@, "");
eval { $foo->{model}->check_model('', ['bar', 'bang']) };
is($@, "");
eval { $foo->{model}->check_final_model('', ['bar', 'bang', 'bop', 'baz']) };
like($@, qr/do not match content model/);
eval { $foo->{model}->check_model('', ['baz']) };
like($@, qr/does not match content model/);
XML-Validator-Schema-1.10/t/bad_attribute_type.yml 0000644 0000764 0000764 00000000511 07736372140 020214 0 ustar sam sam # test bad attribute type
--- |
--- |
--- >
FAIL /unrecognized\s+type/
XML-Validator-Schema-1.10/t/06passthru.t 0000644 0000764 0000764 00000001712 07737440646 016037 0 ustar sam sam #!/usr/bin/perl
use strict;
use warnings;
use XML::Validator::Schema;
use XML::SAX::ParserFactory;
BEGIN {
unless (eval "use XML::SAX::Writer; 1;") {
eval "use Test::More skip_all => 'Test requires XML::SAX::Writer'";
} else {
eval "use Test::More qw(no_plan);";
}
}
# run test.xml through the writer with no validator
my $output = "";
my $writer = XML::SAX::Writer->new(Output => \$output);
my $parser = XML::SAX::ParserFactory->parser(Handler => $writer);
$parser->parse_uri('t/test.xml');
ok($output);
# run test.xml through writer, validating against test.xsd
my $output2 = "";
my $writer2 = XML::SAX::Writer->new(Output => \$output2);
my $validator = XML::Validator::Schema->new(file => 't/test.xsd',
Handler => $writer2);
my $parser2 = XML::SAX::ParserFactory->parser(Handler => $validator);
$parser2->parse_uri('t/test.xml');
ok($output2);
# should be the same
is($output, $output2);
XML-Validator-Schema-1.10/t/all_min0.yml 0000644 0000764 0000764 00000001065 10037606506 016034 0 ustar sam sam # test the works correctly with minOccurs="0" elements
--- |
--- |
foobar
--- >
PASS
--- |
foobar
foobar
--- >
PASS
XML-Validator-Schema-1.10/t/sequence_with_choice.yml 0000644 0000764 0000764 00000002316 10142472217 020513 0 ustar sam sam # test a sequence containing a choice
--- |
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL /'middle' does not match content model '\(\(head_one\|head_two\|\(multi_head\+\)\),middle,tail\)'/
--- |
--- >
FAIL
--- |
--- >
FAIL
--- |
--- >
FAIL
XML-Validator-Schema-1.10/t/bad_all.yml 0000644 0000764 0000764 00000000663 07736372140 015730 0 ustar sam sam # simple all test
--- |
--- |
--- >
FAIL /maxOccurs/
XML-Validator-Schema-1.10/t/attribute.yml 0000644 0000764 0000764 00000001006 07737175004 016346 0 ustar sam sam # simple schema with a single element with two attributes
--- |
--- |
--- >
PASS
--- |
--- >
PASS
--- |
--- >
FAIL /[Mm]issing required attribute/
--- |
--- >
FAIL
XML-Validator-Schema-1.10/t/lib/ 0000755 0000764 0000764 00000000000 10750441441 014357 5 ustar sam sam XML-Validator-Schema-1.10/t/lib/YAML.pm 0000644 0000764 0000764 00000136227 07727717747 015523 0 ustar sam sam package YAML;
$VERSION = '0.35';
# This module implements a Loader and Dumper for the YAML serialization
# language, VERSION 1.0 TRIAL2. (http://www.yaml.org/spec/)
require Exporter;
@ISA = qw(Exporter);
# Basic interface is Load & Dump
# Phasing out Store in favor of Dump XXX
# Leave it in for now. XXX
@EXPORT = qw(Load Dump Store);
# Provide a bunch of aliases for TMTOWTDI's sake
@EXPORT_OK = qw(LoadFile DumpFile
Dumper Eval
freeze thaw
VALUE COMMENT
Bless Blessed
);
# Export groups
%EXPORT_TAGS = (all => [qw(Load Dump Store LoadFile DumpFile Bless Blessed)],
constants => [qw(VALUE COMMENT)],
Storable => [qw(freeze thaw)],
POE => [qw(freeze thaw)],
);
use strict;
use YAML::Node;
use YAML::Transfer;
use Carp;
sub PRINT { print STDERR @_, "\n" } # XXX
sub DUMP { use Data::Dumper(); print STDERR Data::Dumper::Dumper(@_) } # XXX
# Context constants
use constant LEAF => 1;
use constant COLLECTION => 2;
use constant KEY => 3;
use constant BLESSED => 4;
use constant FROMARRAY => 5;
use constant VALUE => "\x07YAML\x07VALUE\x07";
use constant COMMENT => "\x07YAML\x07COMMENT\x07";
# These are the user changable options
{
no strict 'vars';
$Indent = 2 unless defined $Indent;
$UseHeader = 1 unless defined $UseHeader;
$UseVersion = 1 unless defined $UseVersion;
$SortKeys = 1 unless defined $SortKeys;
$AnchorPrefix = '' unless defined $AnchorPrefix;
$UseCode = 0 unless defined $UseCode;
$DumpCode = '' unless defined $DumpCode;
$LoadCode = '' unless defined $LoadCode;
$ForceBlock = 0 unless defined $ForceBlock;
$UseBlock = 0 unless defined $UseBlock;
$UseFold = 0 unless defined $UseFold;
$CompressSeries = 1 unless defined $CompressSeries;
$InlineSeries = 0 unless defined $InlineSeries;
$UseAliases = 1 unless defined $UseAliases;
$Purity = 0 unless defined $Purity;
$DateClass = '' unless defined $DateClass;
}
# Common YAML character sets
my $WORD_CHAR = '[A-Za-z-]';
my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
my $INDICATOR_CHAR = '[#-:?*&!|\\\\^@%]';
my $FOLD_CHAR = '>';
my $BLOCK_CHAR = '|';
my $BLOCK_CHAR_RX = "\\$BLOCK_CHAR";
# $o is the YAML object. It contains the complete state of the YAML.pm
# process. This is set at the file scope level so that I can avoid using
# OO syntax or passing the object around in function calls.
#
# When callback are added to YAML.pm the calling code will have to save
# the object so that it won't get clobbered. Also YAML.pm can't be subclassed.
#
# The purpose of this is for efficiency and also for much simpler code.
my $o;
# YAML OO constructor function
sub new {
my $class = shift;
my $o = {
stream => '',
level => 0,
anchor => 1,
Indent => $YAML::Indent,
UseHeader => $YAML::UseHeader,
UseVersion => $YAML::UseVersion,
SortKeys => $YAML::SortKeys,
AnchorPrefix => $YAML::AnchorPrefix,
DumpCode => $YAML::DumpCode,
LoadCode => $YAML::LoadCode,
ForceBlock => $YAML::ForceBlock,
UseBlock => $YAML::UseBlock,
UseFold => $YAML::UseFold,
CompressSeries => $YAML::CompressSeries,
InlineSeries => $YAML::InlineSeries,
UseAliases => $YAML::UseAliases,
Purity => $YAML::Purity,
DateClass => $YAML::DateClass,
};
bless $o, $class;
set_default($o, 'DumpCode', $YAML::UseCode);
set_default($o, 'LoadCode', $YAML::UseCode);
return $o if is_valid($o);
}
my $global = {}; # A global lookup
sub Bless { YAML::bless($global, @_) }
sub Blessed { YAML::blessed($global, @_) }
sub blessed {
my ($o, $ref) = @_;
$ref = \$_[0] unless ref $ref;
my (undef, undef, $node_id) = YAML::Node::info($ref);
$o->{blessed}{$node_id};
}
sub bless {
my ($o, $ref, $blessing) = @_;
my $ynode;
$ref = \$_[0] unless ref $ref;
my (undef, undef, $node_id) = YAML::Node::info($ref);
if (not defined $blessing) {
$ynode = YAML::Node->new($ref);
}
elsif (ref $blessing) {
croak unless ynode($blessing);
$ynode = $blessing;
}
else {
no strict 'refs';
my $transfer = $blessing . "::yaml_dump";
croak unless defined &{$transfer};
$ynode = &{$transfer}($ref);
croak unless ynode($ynode);
}
$o->{blessed}{$node_id} = $ynode;
my $object = ynode($ynode) or croak;
return $object;
}
sub stream {
my ($o, $stream) = @_;
if (not defined $stream) {
return $o->{$stream};
}
elsif (ref($stream) eq 'CODE') {
$o->{stream_fetch} = $stream;
$o->{stream_eos} = 0;
}
elsif ($stream eq '') {
$o->{stream} = '';
}
else {
$o->{stream} .= $stream;
}
}
sub set_default {
my ($o, $option, $default) = (@_);
return if length $o->{$option};
if (length $default) {
$o->{$option} = $default;
}
else {
$o->{$option} = -1;
}
}
sub is_valid {
my ($o) = (@_);
croak YAML_DUMP_ERR_INVALID_INDENT($o->{Indent})
unless ($o->{Indent} =~ /^(\d+)$/) and $1 > 0;
# NOTE: Add more tests...
return 1;
}
#==============================================================================
# Save the contents of a Dump operation to a file. If the file exists
# and has data, and a concatenation was requested, then verify the
# existing header.
sub DumpFile {
my $filename = shift;
local $/ = "\n"; # reset special to "sane"
my $mode = '>';
if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) {
($mode, $filename) = ($1, $2);
}
if ($mode eq '>>' && -f $filename && -s $filename) {
open MYYAML, "< $filename"
or croak YAML_LOAD_ERR_FILE_INPUT($filename, $!);
my $line = ;
close MYYAML;
croak YAML_DUMP_ERR_FILE_CONCATENATE($filename)
unless $line =~ /^---(\s|$)/;
}
open MYYAML, "$mode $filename"
or croak YAML_DUMP_ERR_FILE_OUTPUT($filename, $!);
print MYYAML YAML::Dump(@_);
close MYYAML;
}
# Serialize a list of elements
sub Dump {
$o = YAML->new();
$o->dump(@_);
}
sub Store {
warn YAML_DUMP_WARN_STORE() if $^W;
goto &Dump;
}
# Aliases for Dump
*freeze = *freeze = \&Dump; # alias for Storable or POE users
# OO version of Dump. YAML->new->dump($foo);
sub dump {
$o = shift;
# local $| = 1; # set buffering to "hot" (for testing) XXX
local $/ = "\n"; # reset special to "sane" XXX (danger) fix for callbacks
$o->{stream} = '';
$o->{document} = 0;
for my $document (@_) {
$o->{document}++;
$o->{transferred} = {};
$o->{id_refcnt} = {};
$o->{id_anchor} = {};
$o->{anchor} = 1;
$o->{level} = 0;
$o->{offset}[0] = 0 - $o->{Indent};
_prewalk($document);
_emit_header($document);
_emit_node($document);
}
return $o->{stream};
}
# Every YAML document in the stream must begin with a YAML header, unless
# there is only a single document and the user requests "no header".
sub _emit_header {
my ($node) = @_;
if (not $o->{UseHeader} and
$o->{document} == 1
) {
croak YAML_DUMP_ERR_NO_HEADER() unless ref($node) =~ /^(HASH|ARRAY)$/;
croak YAML_DUMP_ERR_NO_HEADER() if ref($node) eq 'HASH' and
keys(%$node) == 0;
croak YAML_DUMP_ERR_NO_HEADER() if ref($node) eq 'ARRAY' and
@$node == 0;
# XXX Also croak if aliased, blessed, or ynode
$o->{headless} = 1;
return;
}
$o->{stream} .= '---';
if ($o->{UseVersion}) {
$o->{stream} .= " #YAML:1.0";
}
}
# Walk the tree to be dumped and keep track of its reference counts.
# This function is where the Dumper does all its work. All transfers
# happen here.
sub _prewalk {
my $value;
my ($class, $type, $node_id) = YAML::Node::info(\$_[0]);
# Handle typeglobs
if ($type eq 'GLOB') {
$value = $o->{transferred}{$node_id} =
YAML::Transfer::glob::yaml_dump($_[0]);
return _prewalk($value);
}
# Handle regexps
if (ref($_[0]) eq 'Regexp') {
$o->{transferred}{$node_id} = YAML::Transfer::regexp::yaml_dump($_[0]);
return;
}
# Handle Purity for scalars. XXX can't find a use case yet. Might be YAGNI.
if (not ref $_[0]) {
$o->{id_refcnt}{$node_id}++ if $o->{Purity};
return;
}
# Make a copy of original
$value = $_[0];
($class, $type, $node_id) = YAML::Node::info($value);
# Look for things already transferred.
if ($o->{transferred}{$node_id}) {
(undef, undef, $node_id) = (ref $o->{transferred}{$node_id})
? YAML::Node::info($o->{transferred}{$node_id})
: YAML::Node::info(\ $o->{transferred}{$node_id});
$o->{id_refcnt}{$node_id}++;
return;
}
# Handle code refs
if ($type eq 'CODE') {
$o->{transferred}{$node_id} = 'crufty tracking reference placeholder';
YAML::Transfer::code::yaml_dump($o->{DumpCode},
$_[0],
$o->{transferred}{$node_id});
($class, $type, $node_id) =
YAML::Node::info(\ $o->{transferred}{$node_id});
$o->{id_refcnt}{$node_id}++;
return;
}
# Handle blessed things
elsif (defined $class) {
no strict 'refs';
if ($class eq $o->{DateClass}) {
$value = eval "&${class}::yaml_dump(\$value)";
}
elsif (defined &{$class . "::yaml_dump"}) {
$value = eval "&${class}::yaml_dump(\$value)";
}
elsif ($type eq 'SCALAR') {
$o->{transferred}{$node_id} = 'tracking reference placeholder';
YAML::Transfer::blessed::yaml_dump
($_[0], $o->{transferred}{$node_id});
($class, $type, $node_id) =
YAML::Node::info(\ $o->{transferred}{$node_id});
$o->{id_refcnt}{$node_id}++;
return;
}
else {
$value = YAML::Transfer::blessed::yaml_dump($value);
}
$o->{transferred}{$node_id} = $value;
(undef, $type, $node_id) = YAML::Node::info($value);
}
# Handle YAML Blessed things
if (defined $global->{blessed}{$node_id}) {
$value = $global->{blessed}{$node_id};
$o->{transferred}{$node_id} = $value;
($class, $type, $node_id) = YAML::Node::info($value);
return _prewalk($value);
}
# Handle hard refs
if ($type eq 'REF' or $type eq 'SCALAR') {
$value = YAML::Transfer::ref::yaml_dump($value);
$o->{transferred}{$node_id} = $value;
(undef, $type, $node_id) = YAML::Node::info($value);
}
# Handle ref-to-glob's
elsif ($type eq 'GLOB') {
my $ref_ynode = $o->{transferred}{$node_id} =
YAML::Transfer::ref::yaml_dump($value);
my $glob_ynode = $ref_ynode->{&VALUE} =
YAML::Transfer::glob::yaml_dump($$value);
(undef, undef, $node_id) = YAML::Node::info($glob_ynode);
$o->{transferred}{$node_id} = $glob_ynode;
return _prewalk($glob_ynode);
}
# Increment ref count for node
return if ++($o->{id_refcnt}{$node_id}) > 1;
# Continue walking
if ($type eq 'HASH') {
_prewalk($value->{$_}) for keys %{$value};
}
elsif ($type eq 'ARRAY') {
_prewalk($_) for @{$value};
}
}
# Every data element and sub data element is a node. Everything emitted
# goes through this function.
sub _emit_node {
my ($type, $node_id);
my $ref = ref($_[0]);
if ($ref and $ref ne 'Regexp') {
(undef, $type, $node_id) = YAML::Node::info($_[0]);
}
else {
$type = $ref || 'SCALAR';
(undef, undef, $node_id) = YAML::Node::info(\$_[0]);
}
my ($ynode, $family) = ('') x 2;
my ($value, $context) = (@_, 0); # XXX don't copy scalars
if (defined $o->{transferred}{$node_id}) {
$value = $o->{transferred}{$node_id};
$ynode = ynode($value);
if (ref $value) {
$family = defined $ynode ? $ynode->family->short : '';
(undef, $type, $node_id) = YAML::Node::info($value);
}
else {
$family = ynode($o->{transferred}{$node_id})->family->short;
$type = 'SCALAR';
(undef, undef, $node_id) =
YAML::Node::info(\ $o->{transferred}{$node_id});
}
}
elsif ($ynode = ynode($value)) {
$family = $ynode->family->short;
}
if ($o->{UseAliases}) {
$o->{id_refcnt}{$node_id} ||= 0;
if ($o->{id_refcnt}{$node_id} > 1) {
if (defined $o->{id_anchor}{$node_id}) {
$o->{stream} .= ' *' . $o->{id_anchor}{$node_id} . "\n";
return;
}
my $anchor = $o->{AnchorPrefix} . $o->{anchor}++;
$o->{stream} .= ' &' . $anchor;
$o->{id_anchor}{$node_id} = $anchor;
}
}
return _emit_scalar($value, $family) if $type eq 'SCALAR' and $family;
return _emit_str($value) if $type eq 'SCALAR';
return _emit_mapping($value, $family, $node_id, $context) if $type eq 'HASH';
return _emit_sequence($value, $family) if $type eq 'ARRAY';
warn YAML_DUMP_WARN_BAD_NODE_TYPE($type) if $^W;
return _emit_str("$value");
}
# A YAML mapping is akin to a Perl hash.
sub _emit_mapping {
my ($value, $family, $node_id, $context) = @_;
$o->{stream} .= " !$family" if $family;
# Sometimes 'keys' fails. Like on a bad tie implementation.
my $empty_hash = not(eval {keys %$value});
warn YAML_EMIT_WARN_KEYS($@) if $^W and $@;
return ($o->{stream} .= " {}\n") if $empty_hash;
# If CompressSeries is on (default) and legal is this context, then
# use it and make the indent level be 2 for this node.
if ($context == FROMARRAY and $o->{CompressSeries} and
not (defined $o->{id_anchor}{$node_id} or $family or $empty_hash)
) {
$o->{stream} .= ' ';
$o->{offset}[$o->{level}+1] = $o->{offset}[$o->{level}] + 2;
}
else {
$context = 0;
$o->{stream} .= "\n" unless $o->{headless} && not($o->{headless} = 0);
$o->{offset}[$o->{level}+1] = $o->{offset}[$o->{level}] + $o->{Indent};
}
$o->{level}++;
my @keys;
if ($o->{SortKeys} == 1) {
if (ynode($value)) {
@keys = keys %$value;
}
else {
@keys = sort keys %$value;
}
}
elsif ($o->{SortKeys} == 2) {
@keys = sort keys %$value;
}
# XXX This is hackish but sometimes handy. Not sure whether to leave it in.
elsif (ref($o->{SortKeys}) eq 'ARRAY') {
my $i = 1;
my %order = map { ($_, $i++) } @{$o->{SortKeys}};
@keys = sort {
(defined $order{$a} and defined $order{$b})
? ($order{$a} <=> $order{$b})
: ($a cmp $b);
} keys %$value;
}
else {
@keys = keys %$value;
}
# Force the YAML::VALUE ('=') key to sort last.
if (exists $value->{&VALUE}) {
for (my $i = 0; $i < @keys; $i++) {
if ($keys[$i] eq &VALUE) {
splice(@keys, $i, 1);
push @keys, &VALUE;
last;
}
}
}
for my $key (@keys) {
_emit_key($key, $context);
$context = 0;
$o->{stream} .= ':';
_emit_node($value->{$key});
}
$o->{level}--;
}
# A YAML series is akin to a Perl array.
sub _emit_sequence {
my ($value, $family) = @_;
$o->{stream} .= " !$family" if $family;
return ($o->{stream} .= " []\n") if @$value == 0;
$o->{stream} .= "\n" unless $o->{headless} && not($o->{headless} = 0);
# XXX Really crufty feature. Better implemented by ynodes.
if ($o->{InlineSeries} and
@$value <= $o->{InlineSeries} and
not (scalar grep {ref or /\n/} @$value)
) {
$o->{stream} =~ s/\n\Z/ /;
$o->{stream} .= '[';
for (my $i = 0; $i < @$value; $i++) {
_emit_str($value->[$i], KEY);
last if $i == $#{$value};
$o->{stream} .= ', ';
}
$o->{stream} .= "]\n";
return;
}
$o->{offset}[$o->{level} + 1] = $o->{offset}[$o->{level}] + $o->{Indent};
$o->{level}++;
for my $val (@$value) {
$o->{stream} .= ' ' x $o->{offset}[$o->{level}];
$o->{stream} .= '-';
_emit_node($val, FROMARRAY);
}
$o->{level}--;
}
# Emit a mapping key
sub _emit_key {
my ($value, $context) = @_;
$o->{stream} .= ' ' x $o->{offset}[$o->{level}]
unless $context == FROMARRAY;
_emit_str($value, KEY);
}
# Emit a blessed SCALAR
sub _emit_scalar {
my ($value, $family) = @_;
$o->{stream} .= " !$family";
_emit_str($value, BLESSED);
}
# Emit a string value. YAML has many scalar styles. This routine attempts to
# guess the best style for the text.
sub _emit_str {
my $type = $_[1] || 0;
# Use heuristics to find the best scalar emission style.
$o->{offset}[$o->{level} + 1] = $o->{offset}[$o->{level}] + $o->{Indent};
$o->{level}++;
if (defined $_[0] and
$_[0] !~ /$ESCAPE_CHAR/ and
(length($_[0]) > 50 or $_[0] =~ /\n\s/ or
($o->{ForceBlock} and $type != KEY)
)
) {
$o->{stream} .= ($type == KEY) ? '? ' : ' ';
if (($o->{UseFold} and not $o->{ForceBlock}) or
($_[0] =~ /^\S[^\n]{76}/m)
) {
if (is_valid_implicit($_[0]) && # XXX Check implicit check
$type != BLESSED
) {
$o->{stream} .= '! ';
}
_emit_nested($FOLD_CHAR, $_[0]);
}
else {
_emit_nested($BLOCK_CHAR, $_[0]);
}
$o->{stream} .= "\n";
}
else {
$o->{stream} .= ' ' if $type != KEY;
if (defined $_[0] && $_[0] eq VALUE) {
$o->{stream} .= '=';
}
elsif (is_valid_implicit($_[0])) {
_emit_simple($_[0]);
}
elsif ($_[0] =~ /$ESCAPE_CHAR|\n|\'/) {
_emit_double($_[0]);
}
else {
_emit_single($_[0]);
}
$o->{stream} .= "\n" if $type != KEY;
}
$o->{level}--;
return;
}
# Check whether or not a scalar should be emitted as an simple scalar.
sub is_valid_implicit {
return 1 if not defined $_[0];
return 1 if $_[0] =~ /^(-?\d+)$/; # !int
return 1 if $_[0] =~ /^-?\d+\.\d+$/; # !float
return 1 if $_[0] =~ /^-?\d+e[+-]\d+$/; # !float
# XXX - Detect date objects someday (or not)
return 0 if $_[0] =~ /$ESCAPE_CHAR/;
return 0 if $_[0] =~ /(^\s|\:( |$)|\#( |$)|\s$)/;
return 1 if $_[0] =~ /^\w/; # !str
return 0;
}
# A nested scalar is either block or folded
sub _emit_nested {
my ($indicator, $value) = @_;
$o->{stream} .= $indicator;
$value =~ /(\n*)\Z/;
my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-';
$value = '~' if not defined $value;
$o->{stream} .= $chomp;
$o->{stream} .= $o->{Indent} if $value =~ /^\s/;
if ($indicator eq $FOLD_CHAR) {
$value = fold($value);
chop $value unless $chomp eq '+';
}
$o->{stream} .= indent($value);
}
# Simple means that the scalar is unquoted. It is analyzed for its type
# implicitly using regexes.
sub _emit_simple {
$o->{stream} .= defined $_[0] ? $_[0] : '~';
}
# Double quoting is for single lined escaped strings.
sub _emit_double {
(my $escaped = escape($_[0])) =~ s/"/\\"/g;
$o->{stream} .= qq{"$escaped"};
}
# Single quoting is for single lined unescaped strings.
sub _emit_single {
$o->{stream} .= "'$_[0]'";
}
#==============================================================================
# Read a YAML stream from a file and call Load on it.
sub LoadFile {
my $filename = shift;
local $/ = "\n"; # reset special to "sane"
open MYYAML, $filename or croak YAML_LOAD_ERR_FILE_INPUT($filename, $!);
my $yaml = join '', ;
close MYYAML;
return Load($yaml);
}
# Deserialize a YAML stream into a list of data elements
sub Load {
croak YAML_LOAD_USAGE() unless @_ == 1;
$o = YAML->new;
$o->{stream} = defined $_[0] ? $_[0] : '';
return load();
}
# Aliases for Load
*Undent = *Undent = \&Load;
*Eval = *Eval = \&Load;
*thaw = *thaw = \&Load;
# OO version of Load
sub load {
# local $| = 1; # set buffering to "hot" (for testing)
local $/ = "\n"; # reset special to "sane"
return _parse();
}
# Top level function for parsing. Parse each document in order and
# handle processing for YAML headers.
sub _parse {
my (%directives, $preface);
$o->{stream} =~ s|\015\012|\012|g;
$o->{stream} =~ s|\015|\012|g;
$o->{line} = 0;
croak YAML_PARSE_ERR_BAD_CHARS()
if $o->{stream} =~ /$ESCAPE_CHAR/;
croak YAML_PARSE_ERR_NO_FINAL_NEWLINE()
if length($o->{stream}) and
$o->{stream} !~ s/(.)\n\Z/$1/s;
@{$o->{lines}} = split /\x0a/, $o->{stream}, -1;
$o->{line} = 1;
# Throw away any comments or blanks before the header (or start of
# content for headerless streams)
_parse_throwaway_comments();
$o->{document} = 0;
$o->{documents} = [];
# Add an "assumed" header if there is no header and the stream is
# not empty (after initial throwaways).
if (not $o->{eos}) {
if ($o->{lines}[0] !~ /^---(\s|$)/) {
unshift @{$o->{lines}}, '--- #YAML:1.0';
$o->{line}--;
}
}
# Main Loop. Parse out all the top level nodes and return them.
while (not $o->{eos}) {
$o->{anchor2node} = {};
$o->{document}++;
$o->{done} = 0;
$o->{level} = 0;
$o->{offset}[0] = -1;
if ($o->{lines}[0] =~ /^---\s*(.*)$/) {
my @words = split /\s+/, $1;
%directives = ();
while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) {
my ($key, $value) = ($1, $2);
shift(@words);
if (defined $directives{$key}) {
warn YAML_PARSE_WARN_MULTIPLE_DIRECTIVES
($key, $o->{document}) if $^W;
next;
}
$directives{$key} = $value;
}
$o->{preface} = join ' ', @words;
}
else {
croak YAML_PARSE_ERR_NO_SEPARATOR();
}
if (not $o->{done}) {
_parse_next_line(COLLECTION);
}
if ($o->{done}) {
$o->{indent} = -1;
$o->{content} = '';
}
$directives{YAML} ||= '1.0';
$directives{TAB} ||= 'NONE';
($o->{major_version}, $o->{minor_version}) =
split /\./, $directives{YAML}, 2;
croak YAML_PARSE_ERR_BAD_MAJOR_VERSION($directives{YAML})
if ($o->{major_version} ne '1');
warn YAML_PARSE_WARN_BAD_MINOR_VERSION($directives{YAML})
if ($^W and $o->{minor_version} ne '0');
croak "Unrecognized TAB policy" # XXX add to ::Error
unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/;
push @{$o->{documents}}, _parse_node();
}
return wantarray ? @{$o->{documents}} : $o->{documents}[-1];
}
# This function is the dispatcher for parsing each node. Every node
# recurses back through here. (Inlines are an exception as they have
# their own sub-parser.)
sub _parse_node {
# ??????????????????????????????????????
# $|=1;
# print <{indent}
# preface - $o->{preface}
# content - $o->{content}
# level - $o->{level}
# offsets - @{$o->{offset}}
# END
# ??????????????????????????????????????
my $preface = $o->{preface};
$o->{preface} = '';
my ($node, $type, $indicator, $escape, $chomp) = ('') x 5;
my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5;
($anchor, $alias, $explicit, $implicit, $class, $preface) =
_parse_qualifiers($preface);
if ($anchor) {
$o->{anchor2node}{$anchor} = CORE::bless [], 'YAML-anchor2node';
}
$o->{inline} = '';
while (length $preface) {
my $line = $o->{line} - 1;
# XXX rking suggests refactoring the following regex and its evil twin
if ($preface =~ s/^($FOLD_CHAR|$BLOCK_CHAR_RX)(-|\+)?\d*\s*//) {
$indicator = $1;
$chomp = $2 if defined($2);
}
else {
croak YAML_PARSE_ERR_TEXT_AFTER_INDICATOR() if $indicator;
$o->{inline} = $preface;
$preface = '';
}
}
if ($alias) {
croak YAML_PARSE_ERR_NO_ANCHOR($alias)
unless defined $o->{anchor2node}{$alias};
if (ref($o->{anchor2node}{$alias}) ne 'YAML-anchor2node') {
$node = $o->{anchor2node}{$alias};
}
else {
$node = do {my $sv = "*$alias"};
push @{$o->{anchor2node}{$alias}}, [\$node, $o->{line}];
}
}
elsif (length $o->{inline}) {
$node = _parse_inline(1, $implicit, $explicit, $class);
if (length $o->{inline}) {
croak YAML_PARSE_ERR_SINGLE_LINE();
}
}
elsif ($indicator eq $BLOCK_CHAR) {
$o->{level}++;
$node = _parse_block($chomp);
$node = _parse_implicit($node) if $implicit;
$o->{level}--;
}
elsif ($indicator eq $FOLD_CHAR) {
$o->{level}++;
$node = _parse_unfold($chomp);
$node = _parse_implicit($node) if $implicit;
$o->{level}--;
}
else {
$o->{level}++;
$o->{offset}[$o->{level}] ||= 0;
if ($o->{indent} == $o->{offset}[$o->{level}]) {
if ($o->{content} =~ /^-( |$)/) {
$node = _parse_seq($anchor);
}
elsif ($o->{content} =~ /(^\?|\:( |$))/) {
$node = _parse_mapping($anchor);
}
elsif ($preface =~ /^\s*$/) {
$node = _parse_implicit('');
}
else {
croak YAML_PARSE_ERR_BAD_NODE();
}
}
else {
$node = '';
}
$o->{level}--;
}
$#{$o->{offset}} = $o->{level};
if ($explicit) {
if ($class) {
if (not ref $node) {
my $copy = $node;
undef $node;
$node = \$copy;
}
CORE::bless $node, $class;
}
else {
$node = _parse_explicit($node, $explicit);
}
}
if ($anchor) {
if (ref($o->{anchor2node}{$anchor}) eq 'YAML-anchor2node') {
# XXX Can't remember what this code actually does
for my $ref (@{$o->{anchor2node}{$anchor}}) {
${$ref->[0]} = $node;
warn YAML_LOAD_WARN_UNRESOLVED_ALIAS($anchor, $ref->[1]) if $^W;
}
}
$o->{anchor2node}{$anchor} = $node;
}
return $node;
}
# Preprocess the qualifiers that may be attached to any node.
sub _parse_qualifiers {
my ($preface) = @_;
my ($anchor, $alias, $explicit, $implicit, $class, $token) = ('') x 6;
$o->{inline} = '';
while ($preface =~ /^[&*!]/) {
my $line = $o->{line} - 1;
if ($preface =~ s/^\!(\S+)\s*//) {
croak YAML_PARSE_ERR_MANY_EXPLICIT() if $explicit;
$explicit = $1;
}
elsif ($preface =~ s/^\!\s*//) {
croak YAML_PARSE_ERR_MANY_IMPLICIT() if $implicit;
$implicit = 1;
}
elsif ($preface =~ s/^\&([^ ,:]+)\s*//) {
$token = $1;
croak YAML_PARSE_ERR_BAD_ANCHOR()
unless $token =~ /^[a-zA-Z0-9]+$/;
croak YAML_PARSE_ERR_MANY_ANCHOR() if $anchor;
croak YAML_PARSE_ERR_ANCHOR_ALIAS() if $alias;
$anchor = $token;
}
elsif ($preface =~ s/^\*([^ ,:]+)\s*//) {
$token = $1;
croak YAML_PARSE_ERR_BAD_ALIAS() unless $token =~ /^[a-zA-Z0-9]+$/;
croak YAML_PARSE_ERR_MANY_ALIAS() if $alias;
croak YAML_PARSE_ERR_ANCHOR_ALIAS() if $anchor;
$alias = $token;
}
}
return ($anchor, $alias, $explicit, $implicit, $class, $preface);
}
# Morph a node to it's explicit type
sub _parse_explicit {
my ($node, $explicit) = @_;
if ($explicit =~ m{^(int|float|bool|date|time|datetime|binary)$}) {
my $handler = "YAML::_load_$1";
no strict 'refs';
return &$handler($node);
}
elsif ($explicit =~ m{^perl/(glob|regexp|code|ref)\:(\w(\w|\:\:)*)?$}) {
my ($type, $class) = (($1 || ''), ($2 || ''));
my $handler = "YAML::_load_perl_$type";
no strict 'refs';
if (defined &$handler) {
return &$handler($node, $class);
}
else {
croak YAML_LOAD_ERR_NO_CONVERT('XXX', $explicit);
}
}
elsif ($explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$}) {
my ($package) = ($2);
my $handler = "${package}::yaml_load";
no strict 'refs';
if (defined &$handler) {
return &$handler(YAML::Node->new($node, $explicit));
}
else {
return CORE::bless $node, $package;
}
}
elsif ($explicit !~ m|/|) {
croak YAML_LOAD_ERR_NO_CONVERT('XXX', $explicit);
}
else {
return YAML::Node->new($node, $explicit);
}
}
# Morph to a perl reference
sub _load_perl_ref {
my ($node) = @_;
croak YAML_LOAD_ERR_NO_DEFAULT_VALUE('ptr') unless exists $node->{&VALUE};
return \$node->{&VALUE};
}
# Morph to a perl regexp
sub _load_perl_regexp {
my ($node) = @_;
my ($regexp, $modifiers);
if (defined $node->{REGEXP}) {
$regexp = $node->{REGEXP};
delete $node->{REGEXP};
}
else {
warn YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP() if $^W;
return undef;
}
if (defined $node->{MODIFIERS}) {
$modifiers = $node->{MODIFIERS};
delete $node->{MODIFIERS};
} else {
$modifiers = '';
}
for my $elem (sort keys %$node) {
warn YAML_LOAD_WARN_BAD_REGEXP_ELEM($elem) if $^W;
}
my $value = eval "qr($regexp)$modifiers";
if ($@) {
warn YAML_LOAD_WARN_REGEXP_CREATE($regexp, $modifiers, $@) if $^W;
return undef;
}
return $value;
}
# Morph to a perl glob
sub _load_perl_glob {
my ($node) = @_;
my ($name, $package);
if (defined $node->{NAME}) {
$name = $node->{NAME};
delete $node->{NAME};
}
else {
warn YAML_LOAD_WARN_GLOB_NAME() if $^W;
return undef;
}
if (defined $node->{PACKAGE}) {
$package = $node->{PACKAGE};
delete $node->{PACKAGE};
} else {
$package = 'main';
}
no strict 'refs';
if (exists $node->{SCALAR}) {
*{"${package}::$name"} = \$node->{SCALAR};
delete $node->{SCALAR};
}
for my $elem (qw(ARRAY HASH CODE IO)) {
if (exists $node->{$elem}) {
if ($elem eq 'IO') {
warn YAML_LOAD_WARN_GLOB_IO() if $^W;
delete $node->{IO};
next;
}
*{"${package}::$name"} = $node->{$elem};
delete $node->{$elem};
}
}
for my $elem (sort keys %$node) {
warn YAML_LOAD_WARN_BAD_GLOB_ELEM($elem) if $^W;
}
return *{"${package}::$name"};
}
# Special support for an empty mapping
#sub _parse_str_to_map {
# my ($node) = @_;
# croak YAML_LOAD_ERR_NON_EMPTY_STRING('mapping') unless $node eq '';
# return {};
#}
# Special support for an empty sequence
#sub _parse_str_to_seq {
# my ($node) = @_;
# croak YAML_LOAD_ERR_NON_EMPTY_STRING('sequence') unless $node eq '';
# return [];
#}
# Support for sparse sequences
#sub _parse_map_to_seq {
# my ($node) = @_;
# my $seq = [];
# for my $index (keys %$node) {
# croak YAML_LOAD_ERR_BAD_MAP_TO_SEQ($index) unless $index =~ /^\d+/;
# $seq->[$index] = $node->{$index};
# }
# return $seq;
#}
# Support for !int
sub _load_int {
my ($node) = @_;
croak YAML_LOAD_ERR_BAD_STR_TO_INT() unless $node =~ /^-?\d+$/;
return $node;
}
# Support for !date
sub _load_date {
my ($node) = @_;
croak YAML_LOAD_ERR_BAD_STR_TO_DATE() unless $node =~ /^\d\d\d\d-\d\d-\d\d$/;
return $node;
}
# Support for !time
sub _load_time {
my ($node) = @_;
croak YAML_LOAD_ERR_BAD_STR_TO_TIME() unless $node =~ /^\d\d:\d\d:\d\d$/;
return $node;
}
# Support for !perl/code;deparse
sub _load_perl_code {
my ($node, $class) = @_;
if ($o->{LoadCode}) {
my $code = eval "package main; sub $node";
if ($@) {
warn YAML_LOAD_WARN_PARSE_CODE($@) if $^W;
return sub {};
}
else {
CORE::bless $code, $class if $class;
return $code;
}
}
else {
return sub {};
}
}
# Parse a YAML mapping into a Perl hash
sub _parse_mapping {
my ($anchor) = @_;
my $mapping = {};
$o->{anchor2node}{$anchor} = $mapping;
my $key;
while (not $o->{done} and $o->{indent} == $o->{offset}[$o->{level}]) {
# If structured key:
if ($o->{content} =~ s/^\?\s*//) {
$o->{preface} = $o->{content};
_parse_next_line(COLLECTION);
$key = _parse_node();
$key = "$key";
}
# If "default" key (equals sign)
elsif ($o->{content} =~ s/^\=\s*//) {
$key = VALUE;
}
# If "comment" key (slash slash)
elsif ($o->{content} =~ s/^\=\s*//) {
$key = COMMENT;
}
# Regular scalar key:
else {
$o->{inline} = $o->{content};
$key = _parse_inline();
$key = "$key";
$o->{content} = $o->{inline};
$o->{inline} = '';
}
unless ($o->{content} =~ s/^:\s*//) {
croak YAML_LOAD_ERR_BAD_MAP_ELEMENT();
}
$o->{preface} = $o->{content};
my $line = $o->{line};
_parse_next_line(COLLECTION);
my $value = _parse_node();
if (exists $mapping->{$key}) {
warn YAML_LOAD_WARN_DUPLICATE_KEY() if $^W;
}
else {
$mapping->{$key} = $value;
}
}
return $mapping;
}
# Parse a YAML sequence into a Perl array
sub _parse_seq {
my ($anchor) = @_;
my $seq = [];
$o->{anchor2node}{$anchor} = $seq;
while (not $o->{done} and $o->{indent} == $o->{offset}[$o->{level}]) {
if ($o->{content} =~ /^-(?: (.*))?$/) {
$o->{preface} = defined($1) ? $1 : '';
}
else {
croak YAML_LOAD_ERR_BAD_SEQ_ELEMENT();
}
if ($o->{preface} =~ /^(\s*)(\w.*\:(?: |$).*)$/) {
$o->{indent} = $o->{offset}[$o->{level}] + 2 + length($1);
$o->{content} = $2;
$o->{offset}[++$o->{level}] = $o->{indent};
$o->{preface} = '';
push @$seq, _parse_mapping('');
$o->{level}--;
$#{$o->{offset}} = $o->{level};
}
else {
_parse_next_line(COLLECTION);
push @$seq, _parse_node();
}
}
return $seq;
}
# Parse an inline value. Since YAML supports inline collections, this is
# the top level of a sub parsing.
sub _parse_inline {
my ($top, $top_implicit, $top_explicit, $top_class) = (@_, '', '', '', '');
$o->{inline} =~ s/^\s*(.*)\s*$/$1/;
my ($node, $anchor, $alias, $explicit, $implicit, $class) = ('') x 6;
($anchor, $alias, $explicit, $implicit, $class, $o->{inline}) =
_parse_qualifiers($o->{inline});
if ($anchor) {
$o->{anchor2node}{$anchor} = CORE::bless [], 'YAML-anchor2node';
}
$implicit ||= $top_implicit;
$explicit ||= $top_explicit;
$class ||= $top_class;
($top_implicit, $top_explicit, $top_class) = ('', '', '');
if ($alias) {
croak YAML_PARSE_ERR_NO_ANCHOR($alias)
unless defined $o->{anchor2node}{$alias};
if (ref($o->{anchor2node}{$alias}) ne 'YAML-anchor2node') {
$node = $o->{anchor2node}{$alias};
}
else {
$node = do {my $sv = "*$alias"};
push @{$o->{anchor2node}{$alias}}, [\$node, $o->{line}];
}
}
elsif ($o->{inline} =~ /^\{/) {
$node = _parse_inline_mapping($anchor);
}
elsif ($o->{inline} =~ /^\[/) {
$node = _parse_inline_seq($anchor);
}
elsif ($o->{inline} =~ /^"/) {
$node = _parse_inline_double_quoted();
$node = _unescape($node);
$node = _parse_implicit($node) if $implicit;
}
elsif ($o->{inline} =~ /^'/) {
$node = _parse_inline_single_quoted();
$node = _parse_implicit($node) if $implicit;
}
else {
if ($top) {
$node = $o->{inline};
$o->{inline} = '';
}
else {
$node = _parse_inline_simple();
}
$node = _parse_implicit($node) unless $explicit;
}
if ($explicit) {
if ($class) {
if (not ref $node) {
my $copy = $node;
undef $node;
$node = \$copy;
}
CORE::bless $node, $class;
}
else {
$node = _parse_explicit($node, $explicit);
}
}
if ($anchor) {
if (ref($o->{anchor2node}{$anchor}) eq 'YAML-anchor2node') {
for my $ref (@{$o->{anchor2node}{$anchor}}) {
${$ref->[0]} = $node;
warn YAML_LOAD_WARN_UNRESOLVED_ALIAS($anchor, $ref->[1]) if $^W;
}
}
$o->{anchor2node}{$anchor} = $node;
}
return $node;
}
# Parse the inline YAML mapping into a Perl hash
sub _parse_inline_mapping {
my ($anchor) = @_;
my $node = {};
$o->{anchor2node}{$anchor} = $node;
croak YAML_PARSE_ERR_INLINE_MAP() unless $o->{inline} =~ s/^\{\s*//;
while (not $o->{inline} =~ s/^\}//) {
my $key = _parse_inline();
croak YAML_PARSE_ERR_INLINE_MAP() unless $o->{inline} =~ s/^\: \s*//;
my $value = _parse_inline();
if (exists $node->{$key}) {
warn YAML_LOAD_WARN_DUPLICATE_KEY() if $^W;
}
else {
$node->{$key} = $value;
}
next if $o->{inline} =~ /^\}/;
croak YAML_PARSE_ERR_INLINE_MAP() unless $o->{inline} =~ s/^\,\s*//;
}
return $node;
}
# Parse the inline YAML sequence into a Perl array
sub _parse_inline_seq {
my ($anchor) = @_;
my $node = [];
$o->{anchor2node}{$anchor} = $node;
croak YAML_PARSE_ERR_INLINE_SEQUENCE() unless $o->{inline} =~ s/^\[\s*//;
while (not $o->{inline} =~ s/^\]//) {
my $value = _parse_inline();
push @$node, $value;
next if $o->{inline} =~ /^\]/;
croak YAML_PARSE_ERR_INLINE_SEQUENCE()
unless $o->{inline} =~ s/^\,\s*//;
}
return $node;
}
# Parse the inline double quoted string.
sub _parse_inline_double_quoted {
my $node;
if ($o->{inline} =~ /^"((?:\\"|[^"])*)"\s*(.*)$/) {
$node = $1;
$o->{inline} = $2;
$node =~ s/\\"/"/g;
} else {
croak YAML_PARSE_ERR_BAD_DOUBLE();
}
return $node;
}
# Parse the inline single quoted string.
sub _parse_inline_single_quoted {
my $node;
if ($o->{inline} =~ /^'((?:''|[^'])*)'\s*(.*)$/) {
$node = $1;
$o->{inline} = $2;
$node =~ s/''/'/g;
} else {
croak YAML_PARSE_ERR_BAD_SINGLE();
}
return $node;
}
# Parse the inline unquoted string and do implicit typing.
sub _parse_inline_simple {
my $value;
if ($o->{inline} =~ /^(|[^!@#%^&*].*?)(?=[,[\]{}]|: |- |:\s*$|$)/) {
$value = $1;
substr($o->{inline}, 0, length($1)) = '';
}
else {
croak YAML_PARSE_ERR_BAD_INLINE_IMPLICIT($value);
}
return $value;
}
# Apply regex matching for YAML's implicit types. !str, !int, !real,
# !null, !date and !time
sub _parse_implicit {
my ($value) = @_;
$value =~ s/\s*$//;
return $value if $value eq '';
return $value + 0 if $value =~ /^-?\d+$/;
return $value * 1.0
if ($value =~ /^[+-]?(\d*)(?:\.(\d*))?([Ee][+-]?\d+)?$/) and
(defined($3) ? defined($1) : defined($1) || defined($2));
return "$value" if $value =~ # XXX Change this to a Time::Object
/^\d{4}\-\d\d\-\d\d(T\d\d:\d\d:\d\d(\.\d*[1-9])?(Z|[-+]\d\d(:\d\d)?))?$/;
return "$value" if $value =~ /^\w/;
return undef if $value =~ /^~$/;
return 1 if $value =~ /^\+$/;
return 0 if $value =~ /^-$/;
croak YAML_PARSE_ERR_BAD_IMPLICIT($value);
}
# Unfold a YAML multiline scalar into a single string.
sub _parse_unfold {
my ($chomp) = @_;
my $node = '';
my $space = 0;
while (not $o->{done} and $o->{indent} == $o->{offset}[$o->{level}]) {
$node .= "$o->{content}\n";
_parse_next_line(LEAF);
}
$node =~ s/^(\S.*)\n(?=\S)/$1 /gm;
$node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm;
$node =~ s/\n*\Z// unless $chomp eq '+';
$node .= "\n" unless $chomp;
return $node;
}
# Parse a YAML block style scalar. This is like a Perl here-document.
sub _parse_block {
my ($chomp) = @_;
my $node = '';
while (not $o->{done} and $o->{indent} == $o->{offset}[$o->{level}]) {
$node .= $o->{content} . "\n";
_parse_next_line(LEAF);
}
return $node if '+' eq $chomp;
$node =~ s/\n*\Z/\n/;
$node =~ s/\n\Z// if $chomp eq '-';
return $node;
}
# Handle Perl style '#' comments. Comments must be at the same indentation
# level as the collection line following them.
sub _parse_throwaway_comments {
while (@{$o->{lines}} and
$o->{lines}[0] =~ m{^\s*(\#|$)}
) {
shift @{$o->{lines}};
$o->{line}++;
}
$o->{eos} = $o->{done} = not @{$o->{lines}};
}
# This is the routine that controls what line is being parsed. It gets called
# once for each line in the YAML stream.
#
# This routine must:
# 1) Skip past the current line
# 2) Determine the indentation offset for a new level
# 3) Find the next _content_ line
# A) Skip over any throwaways (Comments/blanks)
# B) Set $o->{indent}, $o->{content}, $o->{line}
# 4) Expand tabs appropriately
sub _parse_next_line {
my ($type) = @_;
my $level = $o->{level};
my $offset = $o->{offset}[$level];
croak YAML_EMIT_ERR_BAD_LEVEL() unless defined $offset;
shift @{$o->{lines}};
$o->{eos} = $o->{done} = not @{$o->{lines}};
return if $o->{eos};
$o->{line}++;
# Determine the offset for a new leaf node
if ($o->{preface} =~ qr/(?:$FOLD_CHAR|$BLOCK_CHAR_RX)(?:-|\+)?(\d*)\s*$/) {
croak YAML_PARSE_ERR_ZERO_INDENT() if length($1) and $1 == 0;
$type = LEAF;
if (length($1)) {
$o->{offset}[$level + 1] = $offset + $1;
}
else {
# First get rid of any comments.
while (@{$o->{lines}} && ($o->{lines}[0] =~ /^\s*#/)) {
$o->{lines}[0] =~ /^( *)/ or die;
last unless length($1) <= $offset;
shift @{$o->{lines}};
$o->{line}++;
}
$o->{eos} = $o->{done} = not @{$o->{lines}};
return if $o->{eos};
if ($o->{lines}[0] =~ /^( *)\S/ and length($1) > $offset) {
$o->{offset}[$level+1] = length($1);
}
else {
$o->{offset}[$level+1] = $offset + 1;
}
}
$offset = $o->{offset}[++$level];
}
# Determine the offset for a new collection level
elsif ($type == COLLECTION and
$o->{preface} =~ /^(\s*(\!\S*|\&\S+))*\s*$/) {
_parse_throwaway_comments();
if ($o->{eos}) {
$o->{offset}[$level+1] = $offset + 1;
return;
}
else {
$o->{lines}[0] =~ /^( *)\S/ or die;
if (length($1) > $offset) {
$o->{offset}[$level+1] = length($1);
}
else {
$o->{offset}[$level+1] = $offset + 1;
}
}
$offset = $o->{offset}[++$level];
}
if ($type == LEAF) {
while (@{$o->{lines}} and
$o->{lines}[0] =~ m{^( *)(\#)} and
length($1) < $offset
) {
shift @{$o->{lines}};
$o->{line}++;
}
$o->{eos} = $o->{done} = not @{$o->{lines}};
}
else {
_parse_throwaway_comments();
}
return if $o->{eos};
if ($o->{lines}[0] =~ /^---(\s|$)/) {
$o->{done} = 1;
return;
}
if ($type == LEAF and
$o->{lines}[0] =~ /^ {$offset}(.*)$/
) {
$o->{indent} = $offset;
$o->{content} = $1;
}
elsif ($o->{lines}[0] =~ /^\s*$/) {
$o->{indent} = $offset;
$o->{content} = '';
}
else {
$o->{lines}[0] =~ /^( *)(\S.*)$/;
# print " indent(${\length($1)}) offsets(@{$o->{offset}}) \n";
while ($o->{offset}[$level] > length($1)) {
$level--;
}
croak YAML_PARSE_ERR_INCONSISTENT_INDENTATION()
if $o->{offset}[$level] != length($1);
$o->{indent} = length($1);
$o->{content} = $2;
}
croak YAML_PARSE_ERR_INDENTATION() if $o->{indent} - $offset > 1;
}
#==============================================================================
# Utility subroutines.
#==============================================================================
# Indent a scalar to the current indentation level.
sub indent {
my ($text) = @_;
return $text unless length $text;
$text =~ s/\n\Z//;
my $indent = ' ' x $o->{offset}[$o->{level}];
$text =~ s/^/$indent/gm;
$text = "\n$text";
return $text;
}
# Fold a paragraph to fit within a certain columnar restraint.
sub fold {
my ($text) = @_;
my $folded = '';
$text =~ s/^(\S.*)\n(?=\S)/$1\n\n/gm;
while (length $text > 0) {
if ($text =~ s/^([^\n]{0,76})(\n|\Z)//) {
$folded .= $1;
}
elsif ($text =~ s/^(.{0,76})\s//) {
$folded .= $1;
}
else {
croak "bad news" unless $text =~ s/(.*?)(\s|\Z)//;
$folded .= $1;
}
$folded .= "\n";
}
return $folded;
}
# Escapes for unprintable characters
my @escapes = qw(\z \x01 \x02 \x03 \x04 \x05 \x06 \a
\x08 \t \n \v \f \r \x0e \x0f
\x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17
\x18 \x19 \x1a \e \x1c \x1d \x1e \x1f
);
# Escape the unprintable characters
sub escape {
my ($text) = @_;
$text =~ s/\\/\\\\/g;
$text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge;
return $text;
}
# Printable characters for escapes
my %unescapes =
(
z => "\x00", a => "\x07", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
# Transform all the backslash style escape characters to their literal meaning
sub _unescape {
my ($node) = @_;
$node =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/
(length($1)>1)?pack("H2",$2):$unescapes{$1}/gex;
return $node;
}
sub DESTROY () {}
sub AUTOLOAD {
(my $autoload = $YAML::AUTOLOAD) =~ s/^YAML:://;
if ($autoload =~ /^[A-Z]/ and
ref($_[0]) eq 'YAML' and
defined $_[0]->{$autoload}
) {
defined($_[1]) ? (($_[0]->{$autoload} = $_[1]), return $_[0])
: return $_[0]->{$autoload};
return;
}
croak "Can't autoload '$YAML::AUTOLOAD'\n"
unless $autoload =~ /^YAML_(PARSE|LOAD|DUMP|EMIT)_(ERR|WARN|USAGE)/;
require YAML::Error;
$o->{error} = YAML::Error->new($autoload, $o->{line}, $o->{document}, @_);
my $o_save = $o;
my $dump = $o->{error}->dump;
$o = $o_save;
return "$dump...\n";
}
1;
XML-Validator-Schema-1.10/t/lib/YAML/ 0000755 0000764 0000764 00000000000 10750441441 015121 5 ustar sam sam XML-Validator-Schema-1.10/t/lib/YAML/Family.pm 0000644 0000764 0000764 00000000231 07727717747 016725 0 ustar sam sam package YAML::Family;
sub new {
my ($class, $self) = @_;
bless \$self, $class
}
sub short {
${$_[0]}
}
sub canonical {
${$_[0]}
}
1;
XML-Validator-Schema-1.10/t/lib/YAML/Node.pm 0000644 0000764 0000764 00000015004 07727717747 016375 0 ustar sam sam package YAML::Node;
use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(ynode);
use strict;
use YAML::Family;
use Carp;
sub ynode {
my $self;
if (ref($_[0]) eq 'HASH') {
$self = tied(%{$_[0]});
}
elsif (ref($_[0]) eq 'ARRAY') {
$self = tied(@{$_[0]});
}
else {
$self = tied($_[0]);
}
return (ref($self) =~ /^yaml_/) ? $self : undef;
}
sub info {
($_[0] =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o);
}
sub new {
my ($class, $node, $family) = @_;
my $self;
$self->{NODE} = $node;
my (undef, $type) = info($node);
$self->{KIND} = (not defined $type) ? 'scalar' :
($type eq 'ARRAY') ? 'sequence' :
($type eq 'HASH') ? 'mapping' :
croak "Can't create YAML::Node from '$type'";
family($self, ($family || ''));
if ($self->{KIND} eq 'scalar') {
yaml_scalar->new($self, $_[1]);
return \ $_[1];
}
my $package = "yaml_" . $self->{KIND};
$package->new($self)
}
sub node { $_->{NODE} }
sub kind { $_->{KIND} }
sub family {
my ($self, $value) = @_;
if (defined $value) {
$self->{FAMILY} = YAML::Family->new($value);
return $self;
}
else {
return $self->{FAMILY};
}
}
sub keys {
my ($self, $value) = @_;
if (defined $value) {
$self->{KEYS} = $value;
return $self;
}
else {
return $self->{KEYS};
}
}
#==============================================================================
package yaml_scalar;
@yaml_scalar::ISA = qw(YAML::Node);
sub new {
my ($class, $self) = @_;
tie $_[2], $class, $self;
}
sub TIESCALAR {
my ($class, $self) = @_;
bless $self, $class;
$self
}
sub FETCH {
my ($self) = @_;
$self->{NODE}
}
sub STORE {
my ($self, $value) = @_;
$self->{NODE} = $value
}
#==============================================================================
package yaml_sequence;
@yaml_sequence::ISA = qw(YAML::Node);
sub new {
my ($class, $self) = @_;
my $new;
tie @$new, $class, $self;
$new
}
sub TIEARRAY {
my ($class, $self) = @_;
bless $self, $class
}
sub FETCHSIZE {
my ($self) = @_;
scalar @{$self->{NODE}};
}
sub FETCH {
my ($self, $index) = @_;
$self->{NODE}[$index]
}
sub STORE {
my ($self, $index, $value) = @_;
$self->{NODE}[$index] = $value
}
sub undone {
die "Not implemented yet"; # XXX
}
*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS =
*undone; # XXX Must implement before release
#==============================================================================
package yaml_mapping;
@yaml_mapping::ISA = qw(YAML::Node);
sub new {
my ($class, $self) = @_;
@{$self->{KEYS}} = sort keys %{$self->{NODE}};
my $new;
tie %$new, $class, $self;
$new
}
sub TIEHASH {
my ($class, $self) = @_;
bless $self, $class
}
sub FETCH {
my ($self, $key) = @_;
if (exists $self->{NODE}{$key}) {
return (grep {$_ eq $key} @{$self->{KEYS}})
? $self->{NODE}{$key} : undef;
}
return $self->{HASH}{$key};
}
sub STORE {
my ($self, $key, $value) = @_;
if (exists $self->{NODE}{$key}) {
$self->{NODE}{$key} = $value;
}
elsif (exists $self->{HASH}{$key}) {
$self->{HASH}{$key} = $value;
}
else {
if (not grep {$_ eq $key} @{$self->{KEYS}}) {
push(@{$self->{KEYS}}, $key);
}
$self->{HASH}{$key} = $value;
}
$value
}
sub DELETE {
my ($self, $key) = @_;
my $return;
if (exists $self->{NODE}{$key}) {
$return = $self->{NODE}{$key};
}
elsif (exists $self->{HASH}{$key}) {
$return = delete $self->{NODE}{$key};
}
for (my $i = 0; $i < @{$self->{KEYS}}; $i++) {
if ($self->{KEYS}[$i] eq $key) {
splice(@{$self->{KEYS}}, $i, 1);
}
}
return $return;
}
sub CLEAR {
my ($self) = @_;
@{$self->{KEYS}} = ();
%{$self->{HASH}} = ();
}
sub FIRSTKEY {
my ($self) = @_;
$self->{ITER} = 0;
$self->{KEYS}[0]
}
sub NEXTKEY {
my ($self) = @_;
$self->{KEYS}[++$self->{ITER}]
}
sub EXISTS {
my ($self, $key) = @_;
exists $self->{NODE}{$key}
}
1;
__END__
=head1 NAME
YAML::Node - A generic data node that encapsulates YAML information
=head1 SYNOPSIS
use YAML;
use YAML::Node;
my $ynode = YAML::Node->new({}, 'ingerson.com/fruit');
%$ynode = qw(orange orange apple red grape green);
print Dump $ynode;
yields:
--- #YAML:1.0 !ingerson.com/fruit
orange: orange
apple: red
grape: green
=head1 DESCRIPTION
A generic node in YAML is similar to a plain hash, array, or scalar node
in Perl except that it must also keep track of its type. The type is a
URI called the YAML type family.
YAML::Node is a class for generating and manipulating these containers.
A YAML node (or ynode) is a tied hash, array or scalar. In most ways it
behaves just like the plain thing. But you can assign and retrieve and
YAML type family URI to it. For the hash flavor, you can also assign the
order that the keys will be retrieved in. By default a ynode will offer
its keys in the same order that they were assigned.
YAML::Node has a class method call new() that will return a ynode. You
pass it a regular node and an optional type family. After that you can
use it like a normal Perl node, but when you YAML::Dump it, the magical
properties will be honored.
This is how you can control the sort order of hash keys during a YAML
serialization. By default, YAML sorts keys alphabetically. But notice
in the above example that the keys were Dumped in the same order they
were assigned.
YAML::Node exports a function called ynode(). This function returns the tied object so that you can call special methods on it like ->keys().
keys() works like this:
use YAML;
use YAML::Node;
%$node = qw(orange orange apple red grape green);
$ynode = YAML::Node->new($node);
ynode($ynode)->keys(['grape', 'apple']);
print Dump $ynode;
produces:
--- #YAML:1.0
grape: green
apple: red
It tells the ynode which keys and what order to use.
ynodes will play a very important role in how programs use YAML. They
are the foundation of how a Perl class can marshall the Loading and
Dumping of its objects.
The upcoming versions of YAML.pm will have much more information on this.
=head1 AUTHOR
Brian Ingerson
=head1 COPYRIGHT
Copyright (c) 2002. Brian Ingerson. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
See L
=cut
XML-Validator-Schema-1.10/t/lib/YAML/Transfer.pm 0000644 0000764 0000764 00000005243 07727717747 017300 0 ustar sam sam package YAML::Transfer;
use strict;
use YAML::Node;
package YAML::Transfer::glob;
sub yaml_dump {
my $ynode = YAML::Node->new({}, 'perl/glob:');
for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
my $value = *{$_[0]}{$type};
$value = $$value if $type eq 'SCALAR';
if (defined $value) {
if ($type eq 'IO') {
my @stats = qw(device inode mode links uid gid rdev size
atime mtime ctime blksize blocks);
undef $value;
$value->{stat} = YAML::Node->new({});
map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
$value->{fileno} = fileno(*{$_[0]});
{
local $^W;
$value->{tell} = tell(*{$_[0]});
}
}
$ynode->{$type} = $value;
}
}
return $ynode;
}
package YAML::Transfer::blessed;
my %sigil = (HASH => '', ARRAY => '@', SCALAR => '$');
sub yaml_dump {
my ($value) = @_;
my ($class, $type) = YAML::Node::info($value);
my $family = "perl/$sigil{$type}$class";
if ($type eq 'SCALAR') {
$_[1] = $$value;
YAML::Node->new($_[1], $family)
} else {
YAML::Node->new($value, $family)
}
}
package YAML::Transfer::code;
my $dummy_warned = 0;
my $default = '{ "DUMMY" }';
sub yaml_dump {
my $code;
my ($dumpflag, $value) = @_;
my ($class, $type) = YAML::Node::info($value);
$class ||= '';
my $family = "perl/code:$class";
if (not $dumpflag) {
$code = $default;
}
else {
bless $value, "CODE" if $class;
eval "use B::Deparse";
my $deparse = B::Deparse->new();
eval {
local $^W = 0;
$code = $deparse->coderef2text($value);
};
if ($@) {
warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
$code = $default;
}
bless $value, $class if $class;
chomp $code;
$code .= "\n";
}
$_[2] = $code;
YAML::Node->new($_[2], $family);
}
package YAML::Transfer::ref;
sub yaml_dump {
YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, 'perl/ref:')
}
package YAML::Transfer::regexp;
# XXX Be sure to handle blessed regexps (if possible)
sub yaml_dump {
my ($value) = @_;
my ($regexp, $modifiers);
if ("$value" =~ /^\(\?(\w*)(?:\-\w+)?\:(.*)\)$/) {
$regexp = $2;
$modifiers = $1 || '';
}
else {
croak YAML::YAML_DUMP_ERR_BAD_REGEXP($value);
}
my $ynode = YAML::Node->new({}, 'perl/regexp:');
$ynode->{REGEXP} = $regexp;
$ynode->{MODIFIERS} = $modifiers if $modifiers;
return $ynode;
}
1;
XML-Validator-Schema-1.10/t/lib/YAML/Error.pm 0000644 0000764 0000764 00000014524 07727717747 016607 0 ustar sam sam package YAML::Error;
use strict;
use YAML;
use Carp;
my ($error_messages, %line_adjust);
sub new {
my ($class, $code, $line, $document, @args) = @_;
croak "No such YAML error message: '$code'"
unless defined $error_messages->{$code};
croak "Invalid YAML error code: $code\n"
unless $code =~
/^YAML_(PARSE|LOAD|DUMP|EMIT)_(ERR|WARN|USAGE)(_\w+)?$/;
my ($operation, $severity) = ($1, $2);
my $msg = sprintf($error_messages->{$code}, @args);
$msg =~ s/\\n/\n/g;
$class = 'YAML::Warning' if $severity eq 'WARN';
my $self = bless { code => $code,
msg => $msg,
}, $class;
if ($severity ne 'USAGE' and
$operation eq 'LOAD' or
$operation eq 'PARSE'
) {
$self->{line} = $line - ($line_adjust{$code} || 0);
$self->{document} = $document if defined $document;
}
$self
}
sub msg { $_[0]->{msg} }
sub dump {
my ($self) = @_;
local $YAML::Indent = 4;
local $YAML::UseHeader = 1;
local $YAML::UseVersion = 0;
local $YAML::SortKeys = [qw(code msg line document)];
YAML::Dump($self)
}
%$error_messages = map {s/^\s+//;$_} split "\n", <<'...';
YAML_PARSE_ERR_BAD_CHARS
Invalid characters in stream. This parser only supports printable ASCII
YAML_PARSE_ERR_NO_FINAL_NEWLINE
Stream does not end with newline character
YAML_PARSE_ERR_BAD_MAJOR_VERSION
Can't parse a %s document with a 1.0 parser
YAML_PARSE_WARN_BAD_MINOR_VERSION
Parsing a %s document with a 1.0 parser
YAML_PARSE_WARN_MULTIPLE_DIRECTIVES
'%s directive used more than once'
YAML_PARSE_ERR_TEXT_AFTER_INDICATOR
No text allowed after indicator
YAML_PARSE_ERR_NO_ANCHOR
No anchor for alias '*%s'
YAML_PARSE_ERR_NO_SEPARATOR
Expected separator '---'
YAML_PARSE_ERR_SINGLE_LINE
Couldn't parse single line value
YAML_PARSE_ERR_BAD_ANCHOR
Invalid anchor
YAML_DUMP_ERR_INVALID_INDENT
Invalid Indent width specified: '%s'
YAML_LOAD_USAGE
usage: YAML::Load($yaml_stream_scalar)
YAML_PARSE_ERR_BAD_NODE
Can't parse node
YAML_PARSE_ERR_BAD_EXPLICIT
Unsupported explicit transfer: '%s'
YAML_DUMP_USAGE_DUMPCODE
Invalid value for DumpCode: '%s'
YAML_LOAD_ERR_FILE_INPUT
Couldn't open %s for input:\n%s
YAML_DUMP_ERR_FILE_CONCATENATE
Can't concatenate to YAML file %s
YAML_DUMP_ERR_FILE_OUTPUT
Couldn't open %s for output:\n%s
YAML_DUMP_ERR_NO_HEADER
With UseHeader=0, the node must be a plain hash or array
YAML_DUMP_WARN_BAD_NODE_TYPE
Can't perform serialization for node type %s
YAML_EMIT_WARN_KEYS
Encountered a problem with 'keys':\n%s
YAML_DUMP_WARN_DEPARSE_FAILED
Deparse failed for CODE reference
YAML_DUMP_WARN_CODE_DUMMY
Emitting dummy subroutine for CODE reference
YAML_PARSE_ERR_MANY_EXPLICIT
More than one explicit transfer
YAML_PARSE_ERR_MANY_IMPLICIT
More than one implicit request
YAML_PARSE_ERR_MANY_ANCHOR
More than one anchor
YAML_PARSE_ERR_ANCHOR_ALIAS
Can't define both an anchor and an alias
YAML_PARSE_ERR_BAD_ALIAS
Invalid alias
YAML_PARSE_ERR_MANY_ALIAS
More than one alias
YAML_LOAD_ERR_NO_CONVERT
Can't convert implicit '%s' node to explicit '%s' node
YAML_LOAD_ERR_NO_DEFAULT_VALUE
No default value for '%s' explicit transfer
YAML_LOAD_ERR_NON_EMPTY_STRING
Only the empty string can be converted to a '%s'
YAML_LOAD_ERR_BAD_MAP_TO_SEQ
Can't transfer map as sequence. Non numeric key '%s' encountered.
YAML_DUMP_ERR_BAD_GLOB
'%s' is an invalid value for Perl glob
YAML_DUMP_ERR_BAD_REGEXP
'%s' is an invalid value for Perl Regexp
YAML_DUMP_WARN_STORE
YAML::Store has been deprecated in favor of YAML::Dump
YAML_LOAD_ERR_BAD_STR_TO_INT
Can't transfer string to integer
YAML_LOAD_ERR_BAD_STR_TO_DATE
Can't transfer string to date object
YAML_LOAD_ERR_BAD_STR_TO_TIME
Can't transfer string to time object
YAML_LOAD_ERR_BAD_MAP_ELEMENT
Invalid element in map
YAML_LOAD_WARN_DUPLICATE_KEY
Duplicate map key found. Ignoring.
YAML_LOAD_ERR_BAD_SEQ_ELEMENT
Invalid element in sequence
YAML_PARSE_ERR_INLINE_MAP
Can't parse inline map
YAML_PARSE_ERR_INLINE_SEQUENCE
Can't parse inline sequence
YAML_PARSE_ERR_BAD_DOUBLE
Can't parse double quoted string
YAML_PARSE_ERR_BAD_SINGLE
Can't parse single quoted string
YAML_PARSE_ERR_BAD_INLINE_IMPLICIT
Can't parse inline implicit value '%s'
YAML_PARSE_ERR_BAD_IMPLICIT
Unrecognized implicit value '%s'
YAML_PARSE_ERR_INDENTATION
Error. Invalid indentation level
YAML_PARSE_ERR_INCONSISTENT_INDENTATION
Inconsistent indentation level
YAML_LOAD_WARN_UNRESOLVED_ALIAS
Can't resolve alias *%s
YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP
No 'REGEXP' element for Perl regexp
YAML_LOAD_WARN_BAD_REGEXP_ELEM
Unknown element '%s' in Perl regexp
YAML_LOAD_WARN_REGEXP_CREATE
Couldn't create regexp qr(%s)%s: %s
YAML_LOAD_WARN_GLOB_NAME
No 'NAME' element for Perl glob
YAML_LOAD_WARN_PARSE_CODE
Couldn't parse Perl code scalar: %s
YAML_LOAD_WARN_CODE_DEPARSE
Won't parse Perl code unless $YAML::LoadCode is set
YAML_EMIT_ERR_BAD_LEVEL
Internal Error: Bad level detected
YAML_PARSE_WARN_AMBIGUOUS_TAB
Amibiguous tab converted to spaces
YAML_LOAD_WARN_BAD_GLOB_ELEM
Unknown element '%s' in Perl glob
YAML_PARSE_ERR_ZERO_INDENT
Can't use zero as an indentation width
YAML_LOAD_WARN_GLOB_IO
Can't load an IO filehandle. Yet!!!
...
%line_adjust = map {($_, 1)}
qw(YAML_PARSE_ERR_BAD_MAJOR_VERSION
YAML_PARSE_WARN_BAD_MINOR_VERSION
YAML_PARSE_ERR_TEXT_AFTER_INDICATOR
YAML_PARSE_ERR_NO_ANCHOR
YAML_PARSE_ERR_MANY_EXPLICIT
YAML_PARSE_ERR_MANY_IMPLICIT
YAML_PARSE_ERR_MANY_ANCHOR
YAML_PARSE_ERR_ANCHOR_ALIAS
YAML_PARSE_ERR_BAD_ALIAS
YAML_PARSE_ERR_MANY_ALIAS
YAML_LOAD_ERR_NO_CONVERT
YAML_LOAD_ERR_NO_DEFAULT_VALUE
YAML_LOAD_ERR_NON_EMPTY_STRING
YAML_LOAD_ERR_BAD_MAP_TO_SEQ
YAML_LOAD_ERR_BAD_STR_TO_INT
YAML_LOAD_ERR_BAD_STR_TO_DATE
YAML_LOAD_ERR_BAD_STR_TO_TIME
YAML_LOAD_WARN_DUPLICATE_KEY
YAML_PARSE_ERR_INLINE_MAP
YAML_PARSE_ERR_INLINE_SEQUENCE
YAML_PARSE_ERR_BAD_DOUBLE
YAML_PARSE_ERR_BAD_SINGLE
YAML_PARSE_ERR_BAD_INLINE_IMPLICIT
YAML_PARSE_ERR_BAD_IMPLICIT
YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP
YAML_LOAD_WARN_BAD_REGEXP_ELEM
YAML_LOAD_WARN_REGEXP_CREATE
YAML_LOAD_WARN_GLOB_NAME
YAML_LOAD_WARN_PARSE_CODE
YAML_LOAD_WARN_CODE_DEPARSE
YAML_LOAD_WARN_BAD_GLOB_ELEM
YAML_PARSE_ERR_ZERO_INDENT
);
package YAML::Warning;
use base 'YAML::Error';
1;
XML-Validator-Schema-1.10/t/lib/TestRunner.pm 0000644 0000764 0000764 00000010442 07737327310 017040 0 ustar sam sam # YAML test runner for XML::Validator::Schema. Takes .yml files
# containing a schema and applies it to one or more files evaluating
# the results as specified. Just look at t/*.yml and you'll get the
# idea.
package TestRunner;
use strict;
use warnings;
use Test::Builder;
my $Test = Test::Builder->new;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = ('test_yml', 'foreach_parser', 'test_yml_xerces');
use YAML qw(LoadFile);
use XML::SAX::ParserFactory;
use XML::Validator::Schema;
use XML::SAX;
use Cwd qw(cwd);
use Data::Dumper;
sub foreach_parser (&) {
my $tests = shift;
my @parsers = map { $_->{Name} } (@{XML::SAX->parsers});
@parsers = ($ENV{XMLVS_TEST_PARSER}) if exists $ENV{XMLVS_TEST_PARSER};
# remove XML::LibXML::SAX::Parser and XML::SAX::RTF. Neither works.
@parsers = grep { $_ ne 'XML::LibXML::SAX::Parser' and
$_ ne 'XML::SAX::RTF' } @parsers;
# run tests with all available parsers
foreach my $pkg (@parsers) {
$XML::SAX::ParserPackage = $pkg;
print STDERR "\n\n ======> Testing against $pkg ".
"<======\n\n";
$tests->();
}
}
sub test_yml {
my $file = shift;
my ($prefix) = $file =~ /(\w+)\.yml$/;
my @data = LoadFile($file);
# write out the schema file
my $xsd = shift @data;
open(my $fh, '>', "t/$prefix.xsd") or die $!;
print $fh $xsd;
close($fh) or die $!;
my $num = 0;
while(@data) {
my $xml = shift @data;
my $result = shift @data;
chomp($result);
$num++;
# run the xml through the parser
eval {
my $parser = XML::SAX::ParserFactory->parser(
Handler => XML::Validator::Schema->new(cache => 1,
file => "t/$prefix.xsd"));
$parser->parse_string($xml);
};
my $err = $@;
if ($result =~ m!^FAIL\s*(?:/(.*?)/)?$!) {
my $re = $1;
$Test->ok($err, "$prefix.yml: block $num should fail validation");
if ($re) {
if ($err) {
$Test->like($err, qr/$re/,
"$prefix.yml: block $num should fail matching /$re/");
} else {
$Test->ok(0, "$prefix.yml: block $num should fail matching /$re/");
}
}
} else {
$Test->ok(not($err), "$prefix.yml: block $num should pass validation");
print STDERR "$prefix.yml: block $num ====> $@\n" if $err;
}
}
# cleanup
unlink "t/$prefix.xsd" or die $!;
}
sub test_yml_xerces {
my $file = shift;
my ($prefix) = $file =~ /(\w+)\.yml$/;
my @data = LoadFile($file);
my $old_dir = cwd;
chdir("t") or die "Unable to chdir to t/: $!";
# write out the schema file
my $xsd = shift @data;
open(my $fh, '>', "$prefix.xsd") or die $!;
print $fh $xsd;
close($fh) or die $!;
my $num = 0;
while(@data) {
my $xml = shift @data;
my $result = shift @data;
chomp($result);
$num++;
# fixup $xml to refer to schema
$xml =~ s!<([^?].*?)(/?)>!<$1 xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:noNamespaceSchemaLocation="$prefix.xsd"$2>!;
# write the xml into a temp file
open(XML, '>', "_$prefix.xml") or die $!;
print XML $xml;
close XML;
# run the xml through the parser
my $out = `$ENV{XERCES_DOMCOUNT} -v=always -n -s -f _$prefix.xml 2>&1`;
my $err;
if ($out =~ /Error/) {
$out =~ s!Errors occurred, no output available!!g;
$out =~ s!^\s+!!;
$out =~ s{\s+$}{};
$err = $out;
}
if ($result =~ m!^FAIL\s*(?:/(.*?)/)?$!) {
print STDERR "==> $ENV{XERCES_DOMCOUNT} -v=always -n -s -f _$prefix.xml:\nout\n" unless $err;
$Test->ok($err, "$prefix.yml: block $num should fail validation");
} else {
print STDERR "==> $ENV{XERCES_DOMCOUNT} -v=always -n -s -f _$prefix.xml:\n$out\n" if $err;
$Test->ok(not($err), "$prefix.yml: block $num should pass validation");
}
}
# cleanup
unlink "$prefix.xsd" or die $!;
unlink "_$prefix.xml" or die $!;
chdir($old_dir);
}
1;
XML-Validator-Schema-1.10/t/story.yml 0000644 0000764 0000764 00000013043 07736666126 015540 0 ustar sam sam # real-world schema from a CMS
--- |
--- |
100
cover
Bernstein Infrastructure Ebbing
bogeymen
1
2020-03-24T00:00:00
2
96
97
equilibrium.kra/semblance/
equilibrium.kra/resemblance/
cover
metadata_title
acquaints oleander samson eyeglass
metadata_description
rattlers alfred empty reflecting evasive subsequently grievers construing checks floppies infringe intermediate cytology apologia aggressions planned powdery notoriously blatz incidental prover blower coarsened rioters schematics garcia insertions slyly referee ran asses incrementing incompetent tilted planners final ravages stomp bookmark contained buyers actualities runaway jonas counterfeited gatherings
cover_page
double_column
left_column
lead_in
50
lead_in
62
right_column
image
alignment
Left
media
46
lead_in
87
--- >
PASS
XML-Validator-Schema-1.10/t/plankton.yml 0000644 0000764 0000764 00000007252 07737175004 016202 0 ustar sam sam # plankton's example from Perlmonks, with one change moving the
# maxOccurs="unbounded" from the in lineItems to the
# . http://perlmonks.org/index.pl?node_id=295416
--- |
--- |
A1112CD
Metaphorical Web
James Eldridge
MetWeb
Semantic Web
Sarah Tremaine
SemanticWeb
Essay on Metaphorical
Web
1
Article
155.60
155.60
Lesson Package
4
Lesson
176.13
704.52
860.12
--- >
PASS
XML-Validator-Schema-1.10/t/bad_union.yml 0000644 0000764 0000764 00000002470 10747667031 016310 0 ustar sam sam # Bad (empty) union. This is the only obvious thing I can think of
# that is wrong which would otherwise work
--- |
#########################################################################
Union test
#########################################################################
--- |
union test pass
99999
TBA
--- >
FAIL
XML-Validator-Schema-1.10/t/01basic.t 0000644 0000764 0000764 00000000550 07734672075 015241 0 ustar sam sam #!/usr/bin/perl
use strict;
use warnings;
use Test::More qw(no_plan);
use_ok('XML::Validator::Schema') or exit;
# specifying a non-existent schema file should fail
use XML::SAX::ParserFactory;
eval {
my $parser = XML::SAX::ParserFactory->parser(
Handler => XML::Validator::Schema->new(file => 'nonexistent.xsd'));
};
like($@, qr/does not exist/);
XML-Validator-Schema-1.10/t/bad_type_fractionDigits.yml 0000644 0000764 0000764 00000001021 10140257203 021140 0 ustar sam sam # test disallowed facet types and values
# only 1 test per file, as first test will always fail the whole file when the schema is parsed
--- |
--- |
1
--- >
FAIL /nonNegativeInteger/
XML-Validator-Schema-1.10/t/bad_type_minLength.yml 0000644 0000764 0000764 00000000763 10140257204 020131 0 ustar sam sam # test disallowed facet types and values
# only 1 test per file, as first test will always fail the whole file when the schema is parsed
--- |
--- |
1
--- >
FAIL /nonNegativeInteger/
XML-Validator-Schema-1.10/TODO 0000644 0000764 0000764 00000000747 10142535570 014050 0 ustar sam sam - implement .bad tests
- finish decimal support
- finish dateTime support (hah)
- memory leak testing
- do work in check_contents to avoid printing gobs of content
- XML::Validator::Schema::Simple
- correct namespace processing
- make sure empty content models work
- enforce wierd placement and container-ship rules
- guard against
- add Schema_Type field to SAX data-structures
- groups, ugh
- support more ways to find schema files (schemaLocation)
XML-Validator-Schema-1.10/Schema/ 0000755 0000764 0000764 00000000000 10750441441 014546 5 ustar sam sam XML-Validator-Schema-1.10/Schema/RootNode.pm 0000644 0000764 0000764 00000010342 10120376627 016641 0 ustar sam sam package XML::Validator::Schema::RootNode;
use strict;
use warnings;
use base 'XML::Validator::Schema::ElementNode';
use XML::Validator::Schema::Util qw(_err);
use Carp qw(croak);
=head1 NAME
XML::Validator::Schema::RootNode - the root node in a schema document
=head1 DESCRIPTION
This is an internal module used by XML::Validator::Schema to represent
the root node in an XML Schema document. Holds references to the
libraries for the schema document and is responsible for hooking up
named types to their uses in the node tree at the end of parsing.
=cut
sub new {
my $pkg = shift;
my $self = $pkg->SUPER::new(@_);
# start up with empty libraries
$self->{type_library} = XML::Validator::Schema::TypeLibrary->new;
$self->{element_library} = XML::Validator::Schema::ElementLibrary->new;
$self->{attribute_library} = XML::Validator::Schema::AttributeLibrary->new;
return $self;
}
# finish typing and references
sub compile {
my $self = shift;
my $element_library = $self->{element_library};
# put global elements into the library (could move this to ::ElementNode)
foreach my $d ($self->daughters) {
if (ref($d) eq 'XML::Validator::Schema::ElementNode') {
$element_library->add(name => $d->{name},
obj => $d);
}
}
# complete all element refs first, forming a complete tree
foreach my $element ($self->descendants) {
$self->complete_ref($element);
}
# completa all element types, including their attributes
foreach my $element ($self->descendants) {
$self->complete_type($element);
}
}
sub complete_ref {
my ($self, $ref) = @_;
# handle any unresolved attribute types
if ($ref->{attr}) {
$self->complete_attr_ref($_)
for (grep { $_->{unresolved_ref} } (@{$ref->{attr}}));
}
# all done unless unresolved
return unless $ref->{unresolved_ref};
my $name = $ref->{name};
my ($element) = $self->{element_library}->find(name => $ref->{name});
_err("Found unresolved reference to element '$name'")
unless $element;
# replace the current element
$ref->replace_with($element->copy_at_and_under);
return;
}
sub complete_type {
my ($self, $element) = @_;
my $library = $self->{type_library};
# handle any unresolved attribute types
if ($element->{attr}) {
$self->complete_attr_type($_)
for (grep { $_->{unresolved_type} } (@{$element->{attr}}));
}
# all done unless unresolved
return unless $element->{unresolved_type};
# get type data
my $type_name = $element->{type_name};
my $type = $library->find(name => $type_name);
# isn't there?
_err("Element '<$element->{name}>' has unrecognized type '$type_name'.")
unless $type;
if ($type->isa('XML::Validator::Schema::ComplexTypeNode')) {
# can't have daughters for this to work
_err("Element '<$element->{name}>' is using a named complexType and has sub-elements of its own. That's not supported.")
if $element->daughters;
# replace the current element with one based on the complex node
my $new_node = $type->copy_at_and_under;
$new_node->name($element->{name});
$new_node->{attr} = [ @{ $new_node->{attr} || [] },
@{ $element->{attr} || [] } ];
$element->replace_with($new_node);
} elsif ($type->isa('XML::Validator::Schema::SimpleType')) {
$element->{type} = $type;
} else {
croak("Library returned '$type'!");
}
# fixed it
delete $element->{unresolved_type};
}
sub complete_attr_type {
my ($self, $attr) = @_;
my $type = $self->{type_library}->find(name => $attr->{type_name});
_err("Attribute '<$attr->{name}>' has unrecognized ".
"type '$attr->{type_name}'.")
unless $type;
$attr->{type} = $type;
delete $attr->{unresolved_type};
}
sub complete_attr_ref {
my ($self, $ref) = @_;
my $attr = $self->{attribute_library}->find(name => $ref->{name});
_err("Attribute reference '$ref->{name}' not found.")
unless $attr;
# clone, keep use
my $use = $ref->{required};
%$ref = %$attr;
$ref->{required} = $use;
return;
}
1;
XML-Validator-Schema-1.10/Schema/Node.pm 0000644 0000764 0000764 00000001325 07736111121 015771 0 ustar sam sam package XML::Validator::Schema::Node;
use base qw(Tree::DAG_Node);
=head1 NAME
XML::Validator::Schema::Node
=head1 DESCRIPTION
Base class for nodes in the schema tree. Used by both temporary nodes
resolved during compilation (ex. ::ModelNode) and permanent nodes
(ex. ::ElementNode).
This is an abstract base class and may not be directly instantiated.
=cut
sub new {
my $pkg = shift;
croak("Illegal attempt to instantiate a Node directly!")
if $pkg eq __PACKAGE__;
return $pkg->SUPER::new(@_);
}
sub parse {
my $pkg = shift;
croak("$pkg neglected to supply a parse() implementation!");
}
# override to declare root-ness
sub is_root {
return 0 if shift->{mother};
return 1;
}
1;
XML-Validator-Schema-1.10/Schema/SimpleType.pm 0000644 0000764 0000764 00000045202 10747671171 017215 0 ustar sam sam package XML::Validator::Schema::SimpleType;
use strict;
use warnings;
=item NAME
XML::Validator::Schema::SimpleType
=head1 DESCRIPTION
XML Schema simple type system. This module provides objects and class
methods to support simple types. For complex types see the ModelNode
class.
=head1 USAGE
# create a new anonymous type based on an existing type
my $type = $string->derive();
# create a new named type based on an existing type
my $type = $string->derive(name => 'myString');
# add a restriction
$type->restrict(enumeration => "10");
# check a value against a type
($ok, $msg) = $type->check($value);
=cut
use Carp qw(croak);
use XML::Validator::Schema::Util qw(XSD _err);
# facet support bit-patterns
use constant LENGTH => 0b0000000000000001;
use constant MINLENGTH => 0b0000000000000010;
use constant MAXLENGTH => 0b0000000000000100;
use constant PATTERN => 0b0000000000001000;
use constant ENUMERATION => 0b0000000000010000;
use constant WHITESPACE => 0b0000000000100000;
use constant MAXINCLUSIVE => 0b0000000001000000;
use constant MAXEXCLUSIVE => 0b0000000010000000;
use constant MININCLUSIVE => 0b0000000100000000;
use constant MINEXCLUSIVE => 0b0000001000000000;
use constant TOTALDIGITS => 0b0000010000000000;
use constant FRACTIONDIGITS => 0b0000100000000000;
# hash mapping names to values
our %FACET = (length => LENGTH,
minLength => MINLENGTH,
maxLength => MAXLENGTH,
pattern => PATTERN,
enumeration => ENUMERATION,
whiteSpace => WHITESPACE,
maxInclusive => MAXINCLUSIVE,
maxExclusive => MAXEXCLUSIVE,
minInclusive => MININCLUSIVE,
minExclusive => MINEXCLUSIVE,
totalDigits => TOTALDIGITS,
fractionDigits => FRACTIONDIGITS);
# initialize builtin types
our %BUILTIN;
# create the primitive types
$BUILTIN{string} = __PACKAGE__->new(name => 'string',
facets => LENGTH|MINLENGTH|MAXLENGTH|
PATTERN|ENUMERATION|WHITESPACE,
);
$BUILTIN{boolean} = __PACKAGE__->new(name => 'boolean',
facets => PATTERN|WHITESPACE,
);
$BUILTIN{boolean}->restrict(enumeration => "1",
enumeration => "0",
enumeration => "true",
enumeration => "false");
$BUILTIN{decimal} = __PACKAGE__->new(name => 'decimal',
facets => TOTALDIGITS|FRACTIONDIGITS|
PATTERN|WHITESPACE|
#ENUMERATION|
MAXINCLUSIVE|MAXEXCLUSIVE|
MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{decimal}->restrict(pattern => qr/^[+-]?(?:(?:\d+(?:\.\d+)?)|(?:\.\d+))$/);
$BUILTIN{dateTime} = __PACKAGE__->new(name => 'dateTime',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{dateTime}->restrict(pattern => qr/^[-+]?(\d{4,})-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}(?:\.\d+)?(?:(?:Z)|(?:[-+]\d{2}:\d{2}))?$/);
$BUILTIN{float} = __PACKAGE__->new(name => 'float',
facets => PATTERN|WHITESPACE,
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE);
);
$BUILTIN{float}->restrict(pattern =>
qr/^[+-]?(?:(?:INF)|(?:NaN)|(?:\d+(?:\.\d+)?)(?:[eE][+-]?\d+)?)$/);
$BUILTIN{double} = __PACKAGE__->new(name => 'double',
facets => PATTERN|WHITESPACE,
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE);
);
$BUILTIN{double}->restrict(pattern =>
qr/^[+-]?(?:(?:INF)|(?:NaN)|(?:\d+(?:\.\d+)?)(?:[eE][+-]?\d+)?)$/);
$BUILTIN{duration} = __PACKAGE__->new(name => 'duration',
facets => PATTERN|WHITESPACE,);
#facets => PATTERN|WHITESPACE|ENUMERATION|MAXINCLUSIVE|MAXEXCLUSIVE|MININCLUSIVE|MINEXCLUSIVE);
# thanks to perlmonk Abigail-II
$BUILTIN{duration}->restrict(pattern => qr /^-? # Optional leading minus.
P # Required.
(?=[T\d]) # Duration cannot be empty.
(?:(?!-) \d+ Y)? # Non-negative integer, Y (optional)
(?:(?!-) \d+ M)? # Non-negative integer, M (optional)
(?:(?!-) \d+ D)? # Non-negative integer, D (optional)
(
(?:T (?=\d) # T, must be followed by a digit.
(?:(?!-) \d+ H)? # Non-negative integer, H (optional)
(?:(?!-) \d+ M)? # Non-negative integer, M (optional)
(?:(?!-) \d+\.\d+ S)? # Non-negative decimal, S (optional)
)? # Entire T part is optional
)$/x);
$BUILTIN{time} = __PACKAGE__->new(name => 'time',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{time}->restrict(pattern =>
qr /^[0-2]\d:[0-5]\d:[0-5]\d(\.\d+)?(Z?|([+|-]([0-1]\d|2[0-4])\:([0-5]\d))?)$/);
$BUILTIN{date} = __PACKAGE__->new(name => 'date',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{date}->restrict(pattern =>
qr /^[-]?(\d{4,})-(\d\d)-(\d\d)(??{ _validate_date($1,$2,$3) })(Z?|([+|-]([0-1]\d|2[0-4])\:([0-5]\d))?)$/);
$BUILTIN{gYearMonth} = __PACKAGE__->new(name => 'gYearMonth',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{gYearMonth}->restrict(pattern =>
qr /^[-]?(\d{4,})-(1[0-2]{1}|0\d{1})(Z?|([+|-]([0-1]\d|2[0-4])\:([0-5]\d))?)$/);
$BUILTIN{gYear} = __PACKAGE__->new(name => 'gYear',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{gYear}->restrict(pattern =>
qr /^[-]?(\d{4,})(Z?|([+|-]([0-1]\d|2[0-4])\:([0-5]\d))?)$/);
$BUILTIN{gMonthDay} = __PACKAGE__->new(name => 'gMonthDay',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{gMonthDay}->restrict(pattern =>
qr /^--(\d{2,})-(\d\d)(??{_validate_date(1999,$1,$2)})(Z?|([+|-]([0-1]\d|2[0-4])\:([0-5]\d))?)$/ );
$BUILTIN{gDay} = __PACKAGE__->new(name => 'gDay',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{gDay}->restrict(pattern =>
qr /^---([0-2]\d{1}|3[0|1])(Z?|([+|-]([0-1]\d|2[0-4])\:([0-5]\d))?)$/ );
$BUILTIN{gMonth} = __PACKAGE__->new(name => 'gMonth',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{gMonth}->restrict(pattern =>
qr /^--(0\d|1[0-2])(Z?|([+|-]([0-1]\d|2[0-4])\:([0-5]\d))?)$/ );
$BUILTIN{hexBinary} = __PACKAGE__->new(name => 'hexBinary',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{hexBinary}->restrict(pattern =>
qr /^([0-9a-fA-F][0-9a-fA-F])+$/);
$BUILTIN{base64Binary} = __PACKAGE__->new(name => 'base64Binary',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{base64Binary}->restrict(pattern =>
qr /^([0-9a-zA-Z\+\\\=][0-9a-zA-Z\+\\\=])+$/);
$BUILTIN{anyURI} = __PACKAGE__->new(name => 'anyURI',
facets => LENGTH|MINLENGTH|MAXLENGTH|
PATTERN|ENUMERATION|WHITESPACE,
);
$BUILTIN{QName} = __PACKAGE__->new(name => 'QName',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{QName}->restrict(pattern =>
qr /^([A-z][A-z0-9]+:)?([A-z][A-z0-9]+)$/);
$BUILTIN{NOTATION} = __PACKAGE__->new(name => 'NOTATION',
facets => PATTERN|WHITESPACE
#|ENUMERATION|
#MAXINCLUSIVE|MAXEXCLUSIVE|
#MININCLUSIVE|MINEXCLUSIVE,
);
$BUILTIN{NOTATION}->restrict(pattern =>
qr /^([A-z][A-z0-9]+:)?([A-z][A-z0-9]+)$/);
# create derived types
$BUILTIN{integer} = $BUILTIN{decimal}->derive(name => 'integer');
$BUILTIN{integer}->restrict(pattern => qr/^[+-]?\d+$/);
# http://www.w3.org/TR/2000/CR-xmlschema-2-20001024/#nonPositiveInteger
$BUILTIN{nonPositiveInteger} = $BUILTIN{integer}->derive(name => 'nonPositiveInteger');
$BUILTIN{nonPositiveInteger}->restrict( maxInclusive => 0 );
# http://www.w3.org/TR/2000/CR-xmlschema-2-20001024/#nonNegativeInteger
$BUILTIN{nonNegativeInteger} = $BUILTIN{integer}->derive(name => 'nonNegativeInteger');
$BUILTIN{nonNegativeInteger}->restrict( minInclusive => 0 );
# http://www.w3.org/TR/2000/CR-xmlschema-2-20001024/#positiveInteger
$BUILTIN{positiveInteger} = $BUILTIN{nonNegativeInteger}->derive(name => 'positiveInteger');
$BUILTIN{positiveInteger}->restrict( minInclusive => 1 );
# http://www.w3.org/TR/2000/CR-xmlschema-2-20001024/#negativeInteger
$BUILTIN{negativeInteger} = $BUILTIN{nonPositiveInteger}->derive(name => 'negativeInteger');
$BUILTIN{negativeInteger}->restrict( maxInclusive => -1 );
$BUILTIN{int} = $BUILTIN{integer}->derive(name => 'int');
$BUILTIN{int}->restrict(minInclusive => -2147483648,
maxInclusive => 2147483647);
$BUILTIN{unsignedInt} = $BUILTIN{integer}->derive(name => 'unsignedInt');
$BUILTIN{unsignedInt}->restrict(minInclusive => 0,
maxInclusive => 4294967295);
$BUILTIN{short} = $BUILTIN{int}->derive(name => 'short');
$BUILTIN{short}->restrict(minInclusive => -32768,
maxInclusive => 32767);
$BUILTIN{unsignedShort} = $BUILTIN{unsignedInt}->derive(name =>
'unsignedShort');
$BUILTIN{unsignedShort}->restrict(maxInclusive => 65535);
$BUILTIN{byte} = $BUILTIN{short}->derive(name => 'byte');
$BUILTIN{byte}->restrict(minInclusive => -128,
maxInclusive => 127);
$BUILTIN{unsignedByte} = $BUILTIN{unsignedShort}->derive(name =>
'unsignedByte');
$BUILTIN{unsignedByte}->restrict(maxInclusive => 255);
$BUILTIN{normalizedString} = $BUILTIN{string}->derive(name =>
'normalizedString');
$BUILTIN{normalizedString}->restrict(whiteSpace => 'replace');
$BUILTIN{token} = $BUILTIN{normalizedString}->derive(name => 'token');
$BUILTIN{token}->restrict(whiteSpace => 'collapse');
$BUILTIN{NMTOKEN} = $BUILTIN{token}->derive(name => 'NMTOKEN');
$BUILTIN{NMTOKEN}->restrict(pattern => qr/^[-.:\w\d]*$/);
######################
# SimpleType methods #
######################
# create a new type, filing in the library if named
sub new {
my ($pkg, %arg) = @_;
my $self = bless(\%arg, $pkg);
return $self;
}
# create a type derived from this type
sub derive {
my ($self, @opt) = @_;
my $sub = ref($self)->new(@opt);
$sub->{base} = $self;
return $sub;
}
sub restrict {
my $self = shift;
my $root = $self->root;
while (@_) {
my ($key, $value) = (shift, shift);
# is this a legal restriction? (base types can do whatever they want
_err("Found illegal restriction '$key' on type derived from '$root->{name}'.")
unless ($self == $root) or
($FACET{$key} & $root->{facets});
push @{$self->{restrict}{$key} ||= []}, $value;
}
}
# returns the ultimate base type for this type
sub root {
my $self = shift;
my $p = $self;
while ($p->{base}) {
$p = $p->{base};
}
return $p;
}
sub normalize_ws {
my ($self, $value) = @_;
if ($self->{restrict}{whiteSpace}) {
my $ws = $self->{restrict}{whiteSpace}[0];
if ($ws eq 'replace') {
$value =~ s![\t\n\r]! !g;
} elsif ($ws eq 'collapse') {
$value =~ s!\s+! !g;
$value =~ s!^\s!!g;
$value =~ s!\s$!!g;
}
return $value;
}
return $self->{base}->normalize_ws($value) if $self->{base};
return $value;
}
sub check {
my ($self, $value) = @_;
my $root = $self->root;
my ($ok, $msg);
# first deal with whitespace, necessary before applying facets
$value = $self->normalize_ws($value);
# first check base restrictions
if ($self->{base}) {
($ok, $msg) = $self->{base}->check($value);
return ($ok, $msg) unless $ok;
}
# check various constraints
my $r = $self->{restrict};
if ($r->{length}) {
foreach my $len (@{$r->{length}}) {
return (0, "is not exactly $len characters.")
unless length($value) eq $len;
}
}
if ($r->{maxLength}) {
foreach my $len (@{$r->{maxLength}}) {
return (0, "is longer than maximum $len characters.")
if length($value) > $len;
}
}
if ($r->{minLength}) {
foreach my $len (@{$r->{minLength}}) {
return (0, "is shorter than minimum $len characters.")
if length($value) < $len;
}
}
if ($r->{enumeration}) {
return (0, 'not in allowed list (' .
join(', ', @{$r->{enumeration}}) . ')')
unless grep { $_ eq $value } (@{$r->{enumeration}});
}
if ($r->{pattern}) {
my $pass = 0;
foreach my $pattern (@{$r->{pattern}}) {
if ($value =~ /$pattern/) {
$pass = 1;
last;
}
}
return (0, "does not match required pattern.")
unless $pass;
}
if ($r->{minInclusive}) {
foreach my $min (@{$r->{minInclusive}}) {
return (0, "is below minimum (inclusive) allowed, $min")
if $value < $min;
}
}
if ($r->{minExclusive}) {
foreach my $min (@{$r->{minExclusive}}) {
return (0, "is below minimum allowed, $min")
if $value <= $min;
}
}
if ($r->{maxInclusive}) {
foreach my $max (@{$r->{maxInclusive}}) {
return (0, "is above maximum (inclusive) allowed, $max")
if $value > $max;
}
}
if ($r->{maxExclusive}) {
foreach my $max (@{$r->{maxExclusive}}) {
return (0, "is above maximum allowed, $max")
if $value >= $max;
}
}
if ($r->{totalDigits} or $r->{fractionDigits}) {
# strip leading and trailing zeros for numeric constraints
(my $digits = $value) =~ s/^([+-]?)0*(\d*\.?\d*?)0*$/$1$2/g;
if ($r->{totalDigits}) {
foreach my $tdigits (@{$r->{totalDigits}}) {
return (0, "has more total digits than allowed, $tdigits")
if $digits =~ tr!0-9!! > $tdigits;
}
}
if ($r->{fractionDigits}) {
foreach my $fdigits (@{$r->{fractionDigits}}) {
return (0, "has more fraction digits than allowed, $fdigits")
if $digits =~ /\.\d{$fdigits}\d/;
}
}
}
return (1);
}
#
# begin code taken from Date::Simple
#
my @days_in_month = ([0,31,28,31,30,31,30,31,31,30,31,30,31],
[0,31,29,31,30,31,30,31,31,30,31,30,31]);
sub _validate_date {
my ($y, $m, $d)= @_;
# any +ve integral year is valid
return q{(?!)} if $y != abs int $y;
return q{(?!)} unless 1 <= $m and $m <= 12;
return q{(?!)} unless 1 <= $d and $d <=$days_in_month[_leap_year($y)][$m];
# perl 5.10.0 choked on (?=) here, switching to just returning
# nothing, which should also always match.
return '';
}
sub _leap_year {
my $y = shift;
return (($y%4==0) and ($y%400==0 or $y%100!=0)) || 0;
}
#
# end code taken from Date::Simple
#
1;
XML-Validator-Schema-1.10/Schema/ElementNode.pm 0000644 0000764 0000764 00000015700 10747667266 017333 0 ustar sam sam package XML::Validator::Schema::ElementNode;
use strict;
use warnings;
=head1 NAME
XML::Validator::Schema::ElementNode - an element node in a schema object
=head1 DESCRIPTION
This is an internal module used by XML::Validator::Schema to represent
element nodes derived from XML Schema documents.
=cut
use base qw(XML::Validator::Schema::Node);
use XML::Validator::Schema::Util qw(_attr _err);
# create a node based on the contents of an found in the
# schema document
sub parse {
my ($pkg, $data) = @_;
my $self = $pkg->new();
my $name = _attr($data, 'name');
_err('Found element without a name.')
unless $name;
$self->name($name);
my $type_name = _attr($data, 'type');
if ($type_name) {
$self->{unresolved_type} = 1;
$self->{type_name} = $type_name;
}
my $min = _attr($data, 'minOccurs');
$min = 1 unless defined $min;
_err("Invalid value for minOccurs '$min' found in <$name>.")
unless $min =~ /^\d+$/;
$self->{min} = $min;
my $max = _attr($data, 'maxOccurs');
$max = 1 unless defined $max;
_err("Invalid value for maxOccurs '$max' found in <$name>.")
unless $max =~ /^\d+$/ or $max eq 'unbounded';
$self->{max} = $max;
return $self;
}
# override add_daughter to check parent-specific requirements
sub add_daughter {
my ($self, $d) = @_;
# check that min/mix are 0 or 1 for 'all' contents
if ($self->{is_all} and $d->isa('XML::Validator::Schema::ElementNode')) {
_err("Element '$d->{name}' must have minOccurs of 0 or 1 because it is within an .")
unless ($d->{min} eq '0' or $d->{min} eq '1');
_err("Element '$d->{name}' must have maxOccurs of 0 or 1 because it is within an .")
unless ($d->{max} eq '0' or $d->{max} eq '1');
}
return $self->SUPER::add_daughter($d);
}
# check contents of an element against declared type
sub check_contents {
my ($self, $contents) = @_;
# do type check if a type is declared
if ($self->{type}) {
# Union isn't really a simple type. In a sense it isn't a type
# at all, if it is, it sure as hell isn't simple. It's just
# a rather laissez-faire view of what the type might be.
# Hence I've not handled union in SimpleType::check. As it's
# not handled directly in SimpleType, I've bastardized the usage
# of $self->{type} to just contain a string effectively indicating
# that it is an exception
my ( $ok, $msg);
if ($self->{type} eq 'union' ) {
# it only has to match one of the member types:
if ( not defined($self->{members}) ){
die "Internal error: I aint got no members\n";
} else {
if (@{$self->{members}} == 0 ) {
_err("Element '$self->{name}' is a union with no members.");
}
}
my $types = '';
$ok = 0;
foreach my $m ( @{$self->{members}} ) {
if ( not my $x = ref($m) ) {
die ("Internal error, that isn't a reference\n");
}
( $ok, $msg ) = $m->{type}->check($contents);
last if $ok;
$types .= ' '.$m->{type}->{base}->{name};
}
if ( not $ok ) {
# Just giving the error for the last one checked isn't
# really that helpful. We need to make it explicit that
# NONE of the tests succeeded.
$msg = "content does not match any of the union base types".
" [ $types ]";
}
} else {
($ok, $msg) = $self->{type}->check($contents);
}
_err("Illegal value '$contents' in element <$self->{name}>, $msg")
unless $ok;
}
# mixed content isn't supported, so all complex elements must be
# element only or have nothing but whitespace between the elements
elsif ($self->{is_complex} and $contents =~ /\S/) {
_err("Illegal character data found in element <$self->{name}>.");
}
}
# check if a given name is a legal child, and return it if it is
sub check_daughter {
my ($self, $name) = @_;
my ($daughter) = grep { $_->{name} eq $name } ($self->daughters);
# doesn't even exist?
_err("Found unexpected <$name> inside <$self->{name}>. This is not a valid child element.")
unless $daughter;
# push on
push @{$self->{memory} ||= []}, $name;
# check model
$self->{model}->check_model($self->{name}, $self->{memory})
if $self->{model};
# does this daughter have a valid type? if not, attempt to elaborate
if ($daughter->{unresolved_type}) {
$self->root->complete_type($daughter);
($daughter) = grep { $_->{name} eq $name } ($self->daughters);
}
# is this daughter a dangling ref? if so, complete it
if ($daughter->{unresolved_ref}) {
$self->root->complete_ref($daughter);
($daughter) = grep { $_->{name} eq $name } ($self->daughters);
}
return $daughter;
}
# check that attributes are kosher
sub check_attributes {
my ($self, $data) = @_;
# get lists required and allowed attributes
my (@required, %allowed);
foreach my $attr (@{$self->{attr} || []}) {
$allowed{$attr->{name}} = $attr;
push(@required, $attr->{name}) if $attr->{required};
}
# check attributes
my %saw;
foreach my $jcname (keys %$data) {
my $attr = $data->{$jcname};
# attributes in the http://www.w3.org/2001/XMLSchema-instance
# namespace are processing instructions, not part of the
# document to be validated
next if $attr->{NamespaceURI}
eq 'http://www.w3.org/2001/XMLSchema-instance';
# attributes in http://www.w3.org/2000/xmlns/ are namespace
# declarations and don't concern us
next if $attr->{NamespaceURI} eq 'http://www.w3.org/2000/xmlns/';
my $name = $attr->{LocalName};
my $obj = $allowed{$name};
_err("Illegal attribute '$name' found in <$self->{name}>.")
unless $obj;
$saw{$name} = 1;
# does this obj have an incomplete type? complete it
if ($obj->{unresolved_type}) {
$self->root->complete_attr_type($obj);
}
# check value, if attribute is typed
if ($obj->{type}) {
my ($ok, $msg) = $obj->{type}->check($attr->{Value});
_err("Illegal value '$attr->{Value}' for attribute '$name' in <$self->{name}>, $msg")
unless $ok;
}
}
# make sure all required attributes are present
foreach my $name (@required) {
_err("Missing required attribute '$name' in <$self->{name}>.")
unless $saw{$name};
}
}
# finish
sub compile {
my $self = shift;
if ($self->daughters and
($self->daughters)[0]->isa('XML::Validator::Schema::ModelNode')) {
($self->daughters)[0]->compile;
}
}
# forget about the past
sub clear_memory {
@{$_[0]->{memory}} = () if $_[0]->{memory};
}
1;
XML-Validator-Schema-1.10/Schema/ComplexTypeNode.pm 0000644 0000764 0000764 00000001122 07737440600 020166 0 ustar sam sam package XML::Validator::Schema::ComplexTypeNode;
use strict;
use warnings;
use base 'XML::Validator::Schema::ElementNode';
=head1 NAME
XML::Validator::Schema::ComplexTypeNode
=head1 DESCRIPTION
This is an internal module used by XML::Validator::Schema to represent
complexType nodes derived from XML Schema documents.
=cut
sub compile {
my ($self) = shift;
$self->SUPER::compile();
# register in the library if this is a named type
$self->root->{type_library}->add(name => $self->{name},
obj => $self)
if $self->{name};
}
1;
XML-Validator-Schema-1.10/Schema/Attribute.pm 0000644 0000764 0000764 00000002550 10072566543 017061 0 ustar sam sam package XML::Validator::Schema::Attribute;
use strict;
use warnings;
=head1 NAME
XML::Validator::Schema::Attribute - an attribute node in a schema object
=head1 DESCRIPTION
This is an internal module used by XML::Validator::Schema to represent
attributes derived from XML Schema documents.
=cut
use XML::Validator::Schema::Util qw(_attr _err);
sub new {
my ($pkg, %arg) = @_;
my $self = bless \%arg, $pkg;
}
# create an attribute based on the contents of an element hash
sub parse {
my ($pkg, $data) = @_;
my $self = $pkg->new();
my $name = _attr($data, 'name');
$self->{name} = $name if $name;
my $ref = _attr($data, 'ref');
if ($ref) {
_err("Illegal combination of 'ref' and 'name' in .")
if $name;
$self->{unresolved_ref} = 1;
$self->{name} = $ref;
}
_err("Found with neither 'name' nor 'ref'.")
unless $name or $ref;
my $type_name = _attr($data, 'type');
if ($type_name) {
$self->{unresolved_type} = 1;
$self->{type_name} = $type_name;
}
# load use, defaults to optional
my $use = _attr($data, 'use') || 'optional';
_err("Invalid 'use' value in : '$use'.")
unless $use eq 'optional' or $use eq 'required';
$self->{required} = $use eq 'required' ? 1 : 0;
return $self;
}
1;
XML-Validator-Schema-1.10/Schema/Util.pm 0000644 0000764 0000764 00000001642 07736661000 016031 0 ustar sam sam package XML::Validator::Schema::Util;
use strict;
use warnings;
=head1 NAME
XML::Validator::Schema::Util
=head1 DESCRIPTION
This is an internal module containing a few commonly used functions.
=cut
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(_attr _err XSD);
use XML::SAX::Exception;
# setup an exception class for validation errors
@XML::SAX::Exception::Validator::ISA = qw(XML::SAX::Exception);
use constant XSD => 'http://www.w3.org/2001/XMLSchema';
# get an attribute value by name, ignoring namespaces
sub _attr {
my ($data, $name) = @_;
return $data->{Attributes}{'{}' . $name}{Value}
if exists $data->{Attributes}{'{}' . $name};
foreach my $attr (keys %{$data->{Attributes}}) {
return $data->{$attr}->{Value} if $attr =~ /^\{.*?\}$name/;
}
return;
}
# throw a validator exception
sub _err {
XML::SAX::Exception::Validator->throw(Message => shift);
}
1;
XML-Validator-Schema-1.10/Schema/SimpleTypeNode.pm 0000644 0000764 0000764 00000011273 10747667031 020024 0 ustar sam sam package XML::Validator::Schema::SimpleTypeNode;
use base 'XML::Validator::Schema::Node';
use strict;
use warnings;
use XML::Validator::Schema::Util qw(_attr _err);
use Carp qw(confess);
=head1 NAME
XML::Validator::Schema::SimpleTypeNode
=head1 DESCRIPTION
Temporary node in the schema parse tree to represent a simpleType.
=cut
# Hash mapping facet names to allowable values
our %FACET_VALUE = (length => "nonNegativeInteger",
minLength => "nonNegativeInteger",
maxLength => "nonNegativeInteger",
totalDigits => "positiveInteger",
fractionDigits => "nonNegativeInteger");
sub parse {
my ($pkg, $data) = @_;
my $self = $pkg->new();
my $name = _attr($data, 'name');
$self->name($name) if $name;
$self->{restrictions} = {};
return $self;
}
sub parse_restriction {
my ($self, $data) = @_;
my $base = _attr($data, 'base');
_err("Found restriction without required 'base' attribute.")
unless $base;
$self->{base} = $base;
}
sub parse_facet {
my ($self, $data) = @_;
my $facet = $data->{LocalName};
my $value = _attr($data, 'value');
_err("Found facet <$facet> without required 'value' attribute.")
unless defined $value;
$self->check_facet_value($facet, $value, $FACET_VALUE{$facet}) if defined $FACET_VALUE{$facet};
push @{$self->{restrictions}{$facet} ||= []}, $value;
}
sub compile {
my ($self) = shift;
if ( $self->{mother}->{is_union} ) {
my $mum=$self->{mother};
$self->{name} = $mum->{name} .
$mum->{next_instance};
$self->{mother}->{next_instance} ++;
}
# If my only child is a union, everything is already compiled
if ( $self->{got_union} ) {
# all compilation done at lower level
# it looks sort of inappropriate to return a string when
# everything is expecting a SimpleType in here. But my view is that
# a union isn't really a simpletype and it isn't appropriate to
# handle a union directly in SimpleType. This alerts ElementNode
# to the fact that it has to do a little extra work.
return 'union';
}
# compile a new type
my $base = $self->root->{type_library}->find(name => $self->{base});
my $type = $base->derive();
# smoke 'em if you got 'em
$type->{name} = $self->{name} if $self->{name};
# add restrictions
foreach my $facet (keys %{$self->{restrictions}}) {
foreach my $value (@{$self->{restrictions}{$facet}}) {
if ($facet eq 'pattern') {
$type->restrict($facet, qr/^$value$/);
} else {
$type->restrict($facet, $value);
}
}
}
# register in the library if this is a named type
$self->root->{type_library}->add(name => $self->{name},
obj => $type)
if $self->{name};
if ( $self->{mother}->{is_union} ) {
# update great-gran with this simple type member
# However this node is a SimpleTypeNode, and to make simple
# re-use of 'check' possible in ElementNode, what we should
# be pushing is an ElementNode
my $gg = $self->{mother}->{mother}->{mother};
# Make a new elementnode to stuff into members
my $mbr = XML::Validator::Schema::ElementNode->new();
$mbr->{type} = $type;
# make this simpletype the daughter of the new member element:
$mbr->add_daughter($self);
push(@{$gg->{members}},$mbr);
}
return $type;
}
sub check_facet_value {
my ($self, $facet, $value, $type_name) = @_;
my ($ok, $msg) = $self->root->{type_library}->find(name => $type_name)->check($value);
_err("Facet <$facet> value $value is not a $type_name")
unless $ok;
}
sub check_constraints {
my ($self) = @_;
my $r = $self->{restrictions};
# Schema Component Constraint: fractionDigits-totalDigits
if (exists $r->{fractionDigits} && exists $r->{totalDigits}) {
_err("Facet value $r->{fractionDigits}[0] is greater than facet value $r->{totalDigits}[0]")
if ($r->{fractionDigits}[0] > $r->{totalDigits}[0]);
}
# Schema Component Constraint: length-minLength-maxLength
_err("Facet is defined in addition to facets or ")
if (exists $r->{length} && (exists $r->{minLength} || exists $r->{maxLength}));
# Schema Component Constraint: minLength-less-than-equal-to-maxLength
if (exists $r->{minLength} && exists $r->{maxLength}) {
_err("Facet value $r->{minLength}[0] is greater than than facet value $r->{maxLength}[0]")
if ($r->{minLength}[0] > $r->{maxLength}[0]);
}
}
1;
XML-Validator-Schema-1.10/Schema/ElementLibrary.pm 0000644 0000764 0000764 00000000643 07737327310 020036 0 ustar sam sam package XML::Validator::Schema::ElementLibrary;
use strict;
use warnings;
use XML::Validator::Schema::Util qw(XSD _err);
use base 'XML::Validator::Schema::Library';
=head1 NAME
XML::Validator::Schema::ElementLibrary
=head1 DESCRIPTION
Internal module used to implement a library of elements.
=cut
sub new {
my $pkg = shift;
my $self = $pkg->SUPER::new(what => 'element', @_);
return $self;
}
1;
XML-Validator-Schema-1.10/Schema/ElementRefNode.pm 0000644 0000764 0000764 00000002606 07737175004 017756 0 ustar sam sam package XML::Validator::Schema::ElementRefNode;
use strict;
use warnings;
use base 'XML::Validator::Schema::ElementNode';
use XML::Validator::Schema::Util qw(_err _attr);
use Carp qw(croak);
=head1 NAME
XML::Validator::Schema::ElementRefNode - an element reference node
=head1 DESCRIPTION
This is an internal module used by XML::Validator::Schema to represent
an element reference node.
=cut
sub parse {
my ($pkg, $data) = @_;
my $self = $pkg->new();
my $ref = _attr($data, 'ref');
croak("Why did you create an ElementRefNode if you didn't have a ref?")
unless $ref;
$self->{unresolved_ref} = 1;
$self->name($ref);
my $name = _attr($data, 'name');
_err("Found with illegal combination of 'ref' and 'name' ".
"attributes.")
if $name;
my $type_name = _attr($data, 'type');
_err("Found with illegal combination of 'ref' and 'type' ".
"attributes.")
if $type_name;
my $min = _attr($data, 'minOccurs');
$min = 1 unless defined $min;
_err("Invalid value for minOccurs '$min' found in .")
unless $min =~ /^\d+$/;
$self->{min} = $min;
my $max = _attr($data, 'maxOccurs');
$max = 1 unless defined $max;
_err("Invalid value for maxOccurs '$max' found in .")
unless $max =~ /^\d+$/ or $max eq 'unbounded';
$self->{max} = $max;
return $self;
}
1;
XML-Validator-Schema-1.10/Schema/TypeLibrary.pm 0000644 0000764 0000764 00000001734 07737327310 017370 0 ustar sam sam package XML::Validator::Schema::TypeLibrary;
use strict;
use warnings;
use XML::Validator::Schema::Util qw(XSD _err);
use XML::Validator::Schema::SimpleType;
use base 'XML::Validator::Schema::Library';
=head1 NAME
XML::Validator::Schema::TypeLibrary
=head1 DESCRIPTION
Internal module used to implement a library of types, simple and
complex.
=head1 USAGE
# get a new type library, containing just the builtin types
$library = XML::Validator::Schema::TypeLibrary->new();
# add a new type
$library->add(name => 'myString',
ns => 'http://my/ns',
obj => $type_obj);
# lookup a type
my $type = $library->find(name => 'myString',
ns => 'http://my/ns');
=cut
sub new {
my $pkg = shift;
my $self = $pkg->SUPER::new(what => 'type', @_);
# load builtin simple types into XSD namespace
$self->{stacks}{XSD()} = { %XML::Validator::Schema::SimpleType::BUILTIN };
return $self;
}
1;
XML-Validator-Schema-1.10/Schema/Library.pm 0000644 0000764 0000764 00000002702 10747667324 016531 0 ustar sam sam package XML::Validator::Schema::Library;
use strict;
use warnings;
use XML::Validator::Schema::Util qw(XSD _err);
use Carp qw(croak);
=head1 NAME
XML::Validator::Schema::TypeLibrary
=head1 DESCRIPTION
Internal base class used to implement a libraries of named items.
=cut
sub new {
my $pkg = shift;
my $self = bless({@_}, $pkg);
croak("Missing required 'what' parameter.")
unless $self->{what};
# initialize stacks
$self->{stacks} = {};
return $self;
}
sub find_all {
my $self = shift;
my @ret;
foreach my $ns (keys %{$self->{stacks}}) {
foreach my $name (keys %{$self->{$ns}}) {
push @ret, $self->{stacks}{$ns}{$name};
}
}
return @ret;
}
sub find {
my ($self, %arg) = @_;
croak("Missing required name parameter.") unless $arg{name};
# HACK: fix when QName resolution works
$arg{name} =~ s!^[^:]*:!!;
$arg{ns} ||= XSD;
return $self->{stacks}{$arg{ns}}{$arg{name}};
}
sub add {
my ($self, %arg) = @_;
croak("Missing required name parameter.") unless $arg{name};
croak("Missing required obj parameter.") unless $arg{obj};
# HACK: fix when QName resolution works
$arg{name} =~ s!^\w+:!!;
$arg{ns} ||= XSD;
_err("Illegal attempt to redefine $self->{what} '$arg{name}' ".
"in namespace '$arg{ns}'")
if exists $self->{stacks}{$arg{ns}}{$arg{name}};
$self->{stacks}{$arg{ns}}{$arg{name}} = $arg{obj};
}
1;
XML-Validator-Schema-1.10/Schema/Parser.pm 0000644 0000764 0000764 00000025452 10747667571 016374 0 ustar sam sam package XML::Validator::Schema::Parser;
use strict;
use warnings;
=head1 NAME
XML::Validator::Schema::Parser - XML Schema Document Parser
=head1 DESCRIPTION
This is an internal module used by XML::Validator::Schema to parse XML
Schema documents.
=cut
use base 'XML::SAX::Base';
use XML::Validator::Schema::Util qw(_attr _err);
sub new {
my $pkg = shift;
my $opt = (@_ == 1) ? { %{shift()} } : {@_};
my $self = bless $opt, $pkg;
# start with a dummy root node and an empty stack of elements
$self->{node_stack} = $self->{schema}{node_stack};
return $self;
}
sub start_element {
my ($self, $data) = @_;
my $node_stack = $self->{node_stack};
my $mother = @$node_stack ? $node_stack->[-1] : undef;
my $name = $data->{LocalName};
# make sure schema comes first
_err("Root element must be , fount <$name> instead.")
if @$node_stack == 0 and $name ne 'schema';
# starting up?
if ($name eq 'schema') {
my $node = XML::Validator::Schema::RootNode->new;
$node->name('<<>>');
push(@$node_stack, $node);
# make sure elementFormDefault and attributeFormDefault are
# 'unqualified' if declared since that's all we're up to
for (qw(elementFormDefault attributeFormDefault)) {
my $a = _attr($data, $_);
_err("$_ in must be 'unqualified', ".
"'qualified' is not supported.")
if $a and $a ne 'unqualified';
}
# ignoring targetSchema intentionally. With both Defaults
# unqualified there isn't much point looking at it.
}
# handle element declaration
elsif ($name eq 'element') {
my $node;
if (_attr($data, 'ref')) {
$node = XML::Validator::Schema::ElementRefNode->parse($data);
} else {
# create a new node for the element
$node = XML::Validator::Schema::ElementNode->parse($data);
}
# add to current node's daughter list and become the current node
$mother->add_daughter($node);
push @$node_stack, $node;
}
elsif ($name eq 'attribute') {
# check anonymous/named constraints
my $name = _attr($data, 'name');
_err("Anonymous global simpleType not allowed.")
if not $name and $mother->is_root;
# parse it into an AttributeNode and tell Mom about it
my $node = XML::Validator::Schema::AttributeNode->parse($data);
$mother->add_daughter($node);
push @$node_stack, $node;
}
elsif ($name eq 'simpleContent') {
_err("Found simpleContent outside a complexType.")
unless $mother->{is_complex} or
$mother->isa('XML::Validator::Schema::ComplexTypeNode');
$mother->{simple_content} = 1;
}
elsif ($name eq 'extension') {
_err("Found illegal outside simpleContent.")
unless $mother->{simple_content};
# extract simpleType from base
my $base = _attr($data, 'base');
_err("Found without required 'base' attribute.")
unless $base;
$mother->{type_name} = $base;
$mother->{unresolved_type} = 1;
}
elsif ($name eq 'simpleType') {
my $name = _attr($data, 'name');
if ($name) {
_err("Named simpleType must be global.")
unless $mother->is_root;
# this is a named type, parse it into an SimpleTypeNode
# and tell Mom about it
my $node = XML::Validator::Schema::SimpleTypeNode->parse($data);
$mother->add_daughter($node);
push @$node_stack, $node;
} else {
_err("Anonymous global simpleType not allowed.")
if $mother->is_root;
_err("Found illegally combined with .")
if $mother->{is_complex};
# this is a named type, parse it into a SimpleTypeNode
# and tell Mom about it
my $node = XML::Validator::Schema::SimpleTypeNode->parse($data);
$mother->add_daughter($node);
push @$node_stack, $node;
}
}
elsif ($name eq 'restriction') {
_err("Found outside a definition.")
unless $mother->isa('XML::Validator::Schema::SimpleTypeNode');
$mother->parse_restriction($data);
}
elsif ( $name eq 'union' ) {
_err("Found outside a definition.")
unless $mother->isa('XML::Validator::Schema::SimpleTypeNode');
# The union might just have a 'memberTypes' attribute or it might
# contain a bunch of inline anonymous simpleTypes.
my $node = XML::Validator::Schema::ModelNode->parse($data);
my $gran = $mother->{mother};
$mother->add_daughter($node);
# At parse time, the only node that gets inspected is the
# grandmother node, so let's load everything required at runtime
# onto that
$mother->{got_union} = 1;
$node->{is_union} = 1;
$node->{next_instance} = 0;
$gran->{members} = []; # array of member ElementNodes
if ( _attr($data,'memberTypes') ) {
# Stuff stolen pretty indiscriminately from SimpleTypeNode
my @mts = split(/ +/,_attr($data,'memberTypes'));
foreach my $m ( @mts ) {
my $mbr = XML::Validator::Schema::ElementNode->new();
my $mt = XML::Validator::Schema::SimpleTypeNode->new();
$mt->{base} = $m;
# Why mother->root? well any old valid ref to root will do and
# I can't find one anywhere else...
my $base = $mother->root->{type_library}->find(name => $mt->{base});
my $type = $base->derive();
$mbr->{type} = $type;
$mbr->add_daughter($mt);
push(@{$gran->{members}},$mbr);
$node->{next_instance} ++;
}
}
$node ->{name} = $gran->{name} . '__';
push @$node_stack,$node;
}
elsif ($name eq 'whiteSpace' or
$name eq 'pattern' or
$name eq 'enumeration' or
$name eq 'length' or
$name eq 'minLength' or
$name eq 'maxLength' or
$name eq 'minInclusive' or
$name eq 'minExclusive' or
$name eq 'maxInclusive' or
$name eq 'maxExclusive' or
$name eq 'totalDigits' or
$name eq 'fractionDigits') {
_err("Found <$name> outside a definition.")
unless $mother->isa('XML::Validator::Schema::SimpleTypeNode');
$mother->parse_facet($data);
}
elsif ($name eq 'complexType') {
my $name = _attr($data, 'name');
if ($name) {
_err("Named complexType must be global.")
unless $mother->is_root;
# this is a named type, parse it into an ComplexTypeNode
# and tell Mom about it
my $node = XML::Validator::Schema::ComplexTypeNode->parse($data);
$mother->add_daughter($node);
push @$node_stack, $node;
} else {
_err("Anonymous global complexType not allowed.")
if $mother->is_root;
# anonymous complexTypes are just noted and passed on
$mother->{is_complex} = 1;
}
}
elsif ($name eq 'sequence' or $name eq 'choice' or $name eq 'all') {
# create a new node for the model
my $node = XML::Validator::Schema::ModelNode->parse($data);
# add to current node's daughter list and become the current node
$mother->add_daughter($node);
push @$node_stack, $node;
# all needs special support due to the restrictions on its use
$mother->{is_all} = 1 if $name eq 'all';
}
elsif ($name eq 'annotation' or $name eq 'documentation') {
# skip
}
else {
# getting here is bad news
_err("Unrecognized element '<$name>' found.");
}
}
sub end_element {
my ($self, $data) = @_;
my $node_stack = $self->{node_stack};
my $node = $node_stack->[-1];
my $name = $data->{LocalName};
# all done?
if ($name eq 'schema') {
croak("Module done broke, man. That element stack ain't empty!")
unless @$node_stack == 1;
# finish up
$node_stack->[-1]->compile();
return;
}
# end of an element?
if ($name eq 'element') {
$node->compile();
pop @$node_stack;
return;
}
# end of a model?
if ($name eq 'sequence' or $name eq 'choice' or $name eq 'all') {
pop @$node_stack;
return;
}
# end of a named complexType?
if ($name eq 'complexType' and
$node->isa('XML::Validator::Schema::ComplexTypeNode')) {
$node->compile;
$node->mother->remove_daughter($node);
pop @{$self->{node_stack}};
return;
}
# end of a union?
if ( $name eq 'union' ) {
# Fail if it has no members
if ( $node->{is_union} ) {
if ( not defined($node->{next_instance}) ) {
die "Node is_union but has no next_instance!";
}else {
if ( $node->{next_instance} == 0 ) {
_err("Union defined with no members");
}
}
} else {
die "Node is a a union but not is_union - something is wrong.";
}
pop @$node_stack;
return;
}
# end of named simpleType?
if ( $name eq 'simpleType' and
$node->isa('XML::Validator::Schema::SimpleTypeNode')
)
{
$node->check_constraints();
my $type = $node->compile();
# If the node doesn't have a name, set parent's type
# to be the type of this node
$node->mother->{type} = $type unless $node->{name};
$node->mother->remove_daughter($node);
pop @{$self->{node_stack}};
return;
}
# end of an attribute?
if ($name eq 'attribute' and
$node->isa('XML::Validator::Schema::AttributeNode')) {
my $attr = $node->compile();
my $mother = $node->mother();
my $name = $attr->{name};
if ($name and $mother->is_root) {
# named attribute in the root gets added to the attribute library
$mother->{attribute_library}->add(name => $name,
obj => $attr);
} else {
# attribute in an element goes on the attr array
push @{$mother->{attr} ||= []}, $attr;
}
$node->mother->remove_daughter($node);
pop @{$self->{node_stack}};
return;
}
# it's ok to fall off the end here, not all elements recognized in
# start_element need finalizing.
}
1;
XML-Validator-Schema-1.10/Schema/AttributeLibrary.pm 0000644 0000764 0000764 00000000653 07737327310 020411 0 ustar sam sam package XML::Validator::Schema::AttributeLibrary;
use strict;
use warnings;
use XML::Validator::Schema::Util qw(XSD _err);
use base 'XML::Validator::Schema::Library';
=head1 NAME
XML::Validator::Schema::AttributeLibrary
=head1 DESCRIPTION
Internal module used to implement a library of attributes.
=cut
sub new {
my $pkg = shift;
my $self = $pkg->SUPER::new(what => 'attribute', @_);
return $self;
}
1;
XML-Validator-Schema-1.10/Schema/AttributeNode.pm 0000644 0000764 0000764 00000001374 10205211532 017651 0 ustar sam sam package XML::Validator::Schema::AttributeNode;
use base 'XML::Validator::Schema::Node';
use strict;
use warnings;
use XML::Validator::Schema::Util qw(_attr _err);
use Carp qw(confess);
=head1 NAME
XML::Validator::Schema::AttributeNode
=head1 DESCRIPTION
Temporary node in the schema parse tree to represent an attribute.
=cut
sub parse {
my ($pkg, $data) = @_;
my $self = $pkg->new();
# squirl away data for latter use
$self->{data} = $data;
return $self;
}
sub compile {
my ($self) = shift;
# create a new attribute object and return it
my $attr = XML::Validator::Schema::Attribute->parse($self->{data});
# copy in type info if available
$attr->{type} = $self->{type} if $self->{type};
return $attr;
}
1;
XML-Validator-Schema-1.10/Schema/ModelNode.pm 0000644 0000764 0000764 00000022622 10747667031 016771 0 ustar sam sam package XML::Validator::Schema::ModelNode;
use strict;
use warnings;
use base 'XML::Validator::Schema::Node';
use constant DEBUG => 0;
use Carp qw(croak);
use XML::Validator::Schema::Util qw(_err _attr);
=head1 NAME
XML:Validator::Schema::ModelNode
=head1 DESCRIPTION
Objects of this class represent the content models encountered while
parsing a schema. After a model is completely parsed it is compiled
into a regular expression and a human-readbale description and
assigned to the element or complex type's 'model' attribute.
=cut
# parse a model based on a , , or returning the
# appropriate subclass
sub parse {
my ($pkg, $data) = @_;
my $name = $data->{LocalName};
croak("Unknown model type '$name'")
unless $name eq 'sequence' or $name eq 'choice' or $name eq 'all'
or $name eq 'union';
# construct as appropriate
$pkg = "XML::Validator::Schema::" . ucfirst($name) . "ModelNode";
my $self = $pkg->new();
my $min = _attr($data, 'minOccurs');
$min = 1 unless defined $min;
_err("Invalid value for minOccurs '$min' found in <$name>.")
unless $min =~ /^\d+$/;
$self->{min} = $min;
my $max = _attr($data, 'maxOccurs');
$max = 1 unless defined $max;
_err("Invalid value for maxOccurs '$max' found in <$name>.")
unless $max =~ /^\d+$/ or $max eq 'unbounded';
$self->{max} = $max;
if ($name eq 'all') {
_err("Found with minOccurs neither 0 nor 1.")
unless $self->{min} eq '1' or $self->{min} eq '0';
_err("Found with maxOccurs not 1.")
unless $self->{max} eq '1';
}
return $self;
}
# compile a tree of elements and model nodes into a single model node
# attached to the containing element. This results in a tree
# containing only elements and the element having a 'model' object
# with working check_model() and check_final_model() methods.
sub compile {
my $self = shift;
my $root = $self->mother;
# the root will get assigned all the ElementNodes composing the model.
$root->clear_daughters;
# get two regular expressions, one for verifying the final
# composition of the tree and the other for detecting problems
# mid-model
my ($final_re, $running_re, $desc) = $self->_compile($root);
$self->{description} = $desc;
# hold onto the strings if debugging
$self->{final_re_string} = $final_re if DEBUG;
$self->{running_re_string} = $running_re if DEBUG;
print STDERR "Compile <$root->{name}> content model to:\n\t/$self->{final_re_string}/\n\t/$self->{running_re_string}\n\t$self->{description}\n\n"
if DEBUG;
# compile the regular expressions
eval {
$self->{final_re} = qr/^$final_re$/;
$self->{running_re} = qr/^$running_re$/;
};
croak("Problem compiling content model '<$root->{name}>' into regular expression: $@") if $@;
# finished
$self->clear_daughters;
$root->{model} = $self;
}
# recursive worker for compilation of content models. returns three
# text fragments - ($final_re, $running_re, $description)
sub _compile {
my ($self, $root) = @_;
my @final_parts;
my @running_parts;
my @desc_parts;
foreach my $d ($self->daughters) {
if ($d->isa('XML::Validator::Schema::ElementNode')) {
my $re_name = quotemeta('<' . $d->{name} . '>');
my $qual = _qual($d->{min}, $d->{max});
my $re = length($qual) ? '(?:' . $re_name . ")$qual" : $re_name;
push @final_parts, $re;
my $running_qual = _qual($d->{min} eq '0' ? 0 : 1, $d->{max});
my $running_re = length($running_qual) ? '(?:' . $re_name . ")$running_qual" : $re_name;
push @running_parts, $running_re;
push @desc_parts, $d->{name} . $qual;
# push onto root's daughter list
$root->add_daughter($d);
} elsif ($d->isa('XML::Validator::Schema::ModelNode')) {
# recurse
my ($final_part, $running_part, $desc)
= $d->_compile($root);
push @final_parts, $final_part;
push @running_parts, $running_part;
push @desc_parts, $desc;
} else {
croak("What's a " . ref($d) . " doing here?");
}
}
# combine parts into a regex matching the final and running contents
my $final_re = $self->_combine_final_parts(\@final_parts);
my $running_re = $self->_combine_running_parts(\@running_parts);
my $desc = $self->_combine_desc_parts(\@desc_parts);
return ($final_re, $running_re, $desc);
}
# assign a qualifier based on min/max
sub _qual {
my ($min, $max) = @_;
return "" if $min eq '1' and $max eq '1';
return "+" if $min eq '1' and $max eq 'unbounded';
return "?" if $min eq '0' and $max eq '1';
return "*" if $min eq '0' and $max eq 'unbounded';
return "{$min,}" if $max eq 'unbounded';
return "{$min,$max}";
}
# method to check a final content model
sub check_final_model {
my ($self, $this_name, $names_ref) = @_;
# prepare names for regex
my $names = join('', map { '<' . $_ . '>' } @$names_ref);
print STDERR "Checking element string: '$names' against ".
"'$self->{final_re_string}'\n" if DEBUG;
# do the match and return an error if necessary
if ($names !~ /$self->{final_re}/) {
_err("Contents of element '$this_name' do not match content model '$self->{description}'.");
}
}
# method to check content model in mid-parse. will succeed if the set
# of names constitute at least a prefix of the required content model.
sub check_model {
my ($self, $this_name, $names_ref) = @_;
# prepare names for regex
my $names = join('', map { '<' . $_ . '>' } @$names_ref);
print STDERR "Checking element string: '$names' against ".
"'$self->{running_re_string}'\n" if DEBUG;
# do the match and blame $names[-1] for failures
if ($names !~ /$self->{running_re}/) {
_err("Inside element '$this_name', element '$names_ref->[-1]' does not match content model '$self->{description}'.");
}
}
package XML::Validator::Schema::SequenceModelNode;
use base 'XML::Validator::Schema::ModelNode';
sub _combine_final_parts {
my ($self, $parts) = @_;
# build final re
my $re = '(?:' . join('', @$parts) . ')' .
XML::Validator::Schema::ModelNode::_qual($self->{min}, $self->{max});
return $re;
}
sub _combine_running_parts {
my ($self, $parts) = @_;
# build running re
my $re = join('', map { "(?:$_" } @$parts) .
")?" x @$parts;
$re =~ s!\?$!!;
$re .= XML::Validator::Schema::ModelNode::_qual($self->{min},$self->{max});
return $re;
}
sub _combine_desc_parts {
my ($self, $parts) = @_;
# build description
my $desc = '(' . join(',', @$parts) . ')'
. XML::Validator::Schema::ModelNode::_qual($self->{min}, $self->{max});
return $desc;
}
package XML::Validator::Schema::ChoiceModelNode;
use base 'XML::Validator::Schema::ModelNode';
sub _combine_final_parts {
my ($self, $parts) = @_;
# build final re
my $re = '(?:' . join('|', map { '(?:'. $_ . ')' } @$parts) . ')' .
XML::Validator::Schema::ModelNode::_qual($self->{min}, $self->{max});
return $re;
}
sub _combine_running_parts {
my ($self, $parts) = @_;
# build running re
my $re = '(?:' . $self->_combine_final_parts($parts) . ')' .
XML::Validator::Schema::ModelNode::_qual($self->{min}, $self->{max});
return $re;
}
sub _combine_desc_parts {
my ($self, $parts) = @_;
# build description
my $desc = '(' . join('|', @$parts) . ')' .
XML::Validator::Schema::ModelNode::_qual($self->{min}, $self->{max});
return $desc;
}
package XML::Validator::Schema::UnionModelNode;
use base 'XML::Validator::Schema::ModelNode';
sub _combine_final_parts {
my ($self, $parts) = @_;
# build final re
my $re = '(?:' . join('|', map { '(?:'. $_ . ')' } @$parts) . ')' .
XML::Validator::Schema::ModelNode::_qual($self->{min}, $self->{max});
return $re;
}
sub _combine_running_parts {
my ($self, $parts) = @_;
# build running re
my $re = '(?:' . $self->_combine_final_parts($parts) . ')' .
XML::Validator::Schema::ModelNode::_qual($self->{min}, $self->{max});
return $re;
}
sub _combine_desc_parts {
my ($self, $parts) = @_;
# build description
my $desc = '(' . join('|', @$parts) . ')' .
XML::Validator::Schema::ModelNode::_qual($self->{min}, $self->{max});
return $desc;
}
package XML::Validator::Schema::AllModelNode;
use base 'XML::Validator::Schema::SequenceModelNode';
# an all is just a sequence that doesn't care about ordering and only
# accepts min/max of 0/1
sub _combine_final_parts {
my ($self, $parts) = @_;
return $self->SUPER::_combine_final_parts([sort sort_parts @$parts]);
}
sub _combine_running_parts {
my ($self, $parts) = @_;
return $self->SUPER::_combine_running_parts([sort sort_parts @$parts]);
}
sub _combine_desc_parts {
my ($self, $parts) = @_;
# build description
my $desc = '(' . join('&', @$parts) . ')';
return $desc;
}
# running model check not possible for all, right?
sub check_model {}
sub check_final_model {
my ($self, $this_name, $names_ref) = @_;
$self->SUPER::check_final_model($this_name, [sort @$names_ref]);
}
sub sort_parts {
my( $a_element ) = $a =~ /<(.*?)\\>/;
my( $b_element ) = $b =~ /<(.*?)\\>/;
$a_element cmp $b_element;
}
1;
XML-Validator-Schema-1.10/Schema.pm 0000644 0000764 0000764 00000037767 10750441257 015135 0 ustar sam sam package XML::Validator::Schema;
use 5.006;
use strict;
use warnings;
our $VERSION = '1.10';
=head1 NAME
XML::Validator::Schema - validate XML against a subset of W3C XML Schema
=head1 SYNOPSIS
use XML::SAX::ParserFactory;
use XML::Validator::Schema;
#
# create a new validator object, using foo.xsd
#
$validator = XML::Validator::Schema->new(file => 'foo.xsd');
#
# create a SAX parser and assign the validator as a Handler
#
$parser = XML::SAX::ParserFactory->parser(Handler => $validator);
#
# validate foo.xml against foo.xsd
#
eval { $parser->parse_uri('foo.xml') };
die "File failed validation: $@" if $@;
=head1 DESCRIPTION
This module allows you to validate XML documents against a W3C XML
Schema. This module does not implement the full W3C XML Schema
recommendation (http://www.w3.org/XML/Schema), but a useful subset.
See the L section below.
B: To get line and column numbers in the error
messages generated by this module you must install
L and use
L as your SAX parser. This
module is much more useful if you can tell where your errors are, so
using these modules is highly recommeded!
=head1 INTERFACE
=over 4
=item *
C<< XML::Validator::Schema->new(file => 'file.xsd', cache => 1) >>
Call this method to create a new XML::Validator:Schema object. The
only required option is C which must provide a path to an XML
Schema document.
Setting the optional C parameter to 1 causes
XML::Validator::Schema to keep a copy of the schema parse tree in
memory. The tree will be reused on subsequent calls with the same
C parameter, as long as the mtime on the schema file hasn't
changed. This can save a lot of time if you're validating many
documents against a single schema.
Since XML::Validator::Schema is a SAX filter you will normally pass
this object to a SAX parser:
$validator = XML::Validator::Schema->new(file => 'foo.xsd');
$parser = XML::SAX::ParserFactory->parser(Handler => $validator);
Then you can proceed to validate files using the parser:
eval { $parser->parse_uri('foo.xml') };
die "File failed validation: $@" if $@;
Setting the optional C parameter to 1 causes
XML::Validator::Schema to output elements and associated attributes
while parsing and validating the XML document. This provides useful
information on the position where the validation failed (although not
at useful as the line and column numbers included when
XML::Filter::ExceptiionLocator and XML::SAX::ExpatXS are used).
=back
=head1 RATIONALE
I'm writing a piece of software which uses Xerces/C++
( http://xml.apache.org/xerces-c/ ) to validate documents against XML
Schema schemas. This works very well, but I'd like to release my
project to the world. Requiring users to install Xerces is simply too
onerous a requirement; few will have it already and the Xerces
installation system leaves much to be desired.
On CPAN, the only available XML Schema validator is XML::Schema.
Unfortunately, this module isn't ready for use as it lacks the ability
to actually parse the XML Schema document format! I looked into
enhancing XML::Schema but I must admit that I'm not smart enough to
understand the code... One day, when XML::Schema is completed I will
replace this module with a wrapper around it.
This module represents my attempt to support enough XML Schema syntax
to be useful without attempting to tackle the full standard. I'm sure
this will mean that it can't be used in all situations, but hopefully
that won't prevent it from being used at all.
=head1 SCHEMA SUPPORT
=head2 Supported Elements
The following elements are supported by the XML Schema parser. If you
don't see an element or an attribute here then you definitely can't
use it in a schema document.
You can expect that the schema document parser will produce an error
if you include elements which are not supported. However, unsupported
attributes I be silently ignored. This should not be
misconstrued as a feature and will eventually be fixed.
All of these elements must be in the http://www.w3.org/2001/XMLSchema
namespace, either using a default namespace or a prefix.
Supported attributes: targetNamespace, elementFormDefault,
attributeFormDefault
Notes: the only supported values for elementFormDefault and
attributeFormDefault are "unqualified." As such, targetNamespace
is essentially ignored.
Supported attributes: name, type, minOccurs, maxOccurs, ref
Supported attributes: name, type, use, ref
Supported attributes: minOccurs, maxOccurs
Supported attributes: minOccurs, maxOccurs
Supported attributes: minOccurs, maxOccurs
Supported attributes: name
The only supported sub-element is .
Supported attributes: base
Notes: only allowed inside
Supported attributes: name
Supported attributes: base
Notes: only allowed inside
Supported attributes: value
Supported attributes: value
Supported attributes: value
Supported attributes: value
Supported attributes: value
Supported attributes: value
Supported attributes: value
Supported attributes: value
Supported attributes: value
Supported attributes: value
Supported attributes: value
Supported attributes: value
Supported attributes: name
Supported attributes: MemberTypes
=head2 Simple Type Support
Supported built-in types are:
string
normalizedString
token
NMTOKEN
Notes: the spec says NMTOKEN should only be used for attributes,
but this rule is not enforced.
boolean
decimal
Notes: the enumeration facet is not supported on decimal or any
types derived from decimal.
integer
int
short
byte
unsignedInt
unsignedShort
unsignedByte
positiveInteger
negativeInteger
nonPositiveInteger
nonNegativeInteger
dateTime
Notes: Although dateTime correctly validates the lexical format it does not
offer comparison facets (min*, max*, enumeration).
double
Notes: Although double correctly validates the lexical format it
does not offer comparison facets (min*, max*, enumeration). Also,
minimum and maximum constraints as described in the spec are not
checked.
float
Notes: The restrictions on double support apply to float as well.
duration
time
date
gYearMonth
gYear
gMonthDay
gDay
gMonth
hexBinary
base64Binary
anyURI
QName
NOTATION
=head2 Miscellaneous Details
Other known devations from the specification:
=over
=item *
Patterns specified in pattern simpleType restrictions are Perl regexes
with none of the XML Schema extensions available.
=item *
No effort is made to prevent the declaration of facets which "loosen"
the restrictions on a type. This is a bug and will be fixed in a
future release. Until then types which attempt to loosen restrictions
on their base class will behave unpredictably.
=item *
No attempt has been made to exclude content models which are
ambiguous, as the spec demands. In fact, I don't see any compelling
reason to do so, aside from strict compliance to the spec. The
content model implementaton uses regular expressions which should be
able to handle loads of ambiguity without significant performance
problems.
=item *
Marking a facet "fixed" has no effect.
=item *
SimpleTypes must come after their base types in the schema body. For
example, this is ok:
But this is not:
=back
=head1 CAVEATS
Here are a few gotchas that you should know about:
=over
=item *
No Unicode testing has been performed, although it seems possible that
the module will handle Unicode data correctly.
=item *
Namespace processing is almost entirely missing from the module.
=item *
Little work has been done to ensure that invalid schemas fail
gracefully. Until that is done you may want to develop your schemas
using a more mature validator (like Xerces or XML Spy) before using
them with this module.
=back
=head1 BUGS
Please use C to report bugs in this module:
http://rt.cpan.org
Please note that I will delete bugs which merely point out the lack of
support for a particular feature of XML Schema. Those are feature
requests, and believe me, I know we've got a long way to go.
=head1 SUPPORT
This module is supported on the perl-xml mailing-list. Please join
the list if you have questions, suggestions or patches:
http://listserv.activestate.com/mailman/listinfo/perl-xml
=head1 CVS
If you'd like to help develop XML::Validator::Schema you'll want to
check out a copy of the CVS tree:
http://sourceforge.net/cvs/?group_id=89764
=head1 CREDITS
The following people have contributed bug reports, test cases and/or
code:
Russell B Cecala (aka Plankton)
David Wheeler
Toby Long-Leather
Mathieu
h.bridge@fasol.fujitsu.com
michael.jacob@schering.de
josef@clubphoto.com
adamk@ali.as
Jean Flouret
=head1 AUTHOR
Sam Tregar
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2002-2003 Sam Tregar
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl 5 itself.
=head1 A NOTE ON DEVELOPMENT METHODOLOGY
This module isn't just an XML Schema validator, it's also a test of
the Test Driven Development methodology. I've been writing tests
while I develop code for a while now, but TDD goes further by
requiring tests to be written I code. One consequence of this
is that the module code may seem naive; it really is I
code to pass the current test suite. If I'm doing it right then there
shouldn't be a single line of code that isn't directly related to
passing a test. As I add functionality (by way of writing tests) I'll
refactor the code a great deal, but I won't add code only to support
future development.
For more information I recommend "Test Driven Development: By Example"
by Kent Beck.
=head1 SEE ALSO
L
http://www.w3.org/XML/Schema
http://xml.apache.org/xerces-c/
=cut
use base qw(XML::SAX::Base); # this module is a SAX filter
use Carp qw(croak); # make some noise
use XML::SAX::Exception; # for real
use XML::Filter::BufferText; # keep text together
use XML::SAX::ParserFactory; # needed to parse the schema documents
use XML::Validator::Schema::Parser;
use XML::Validator::Schema::ElementNode;
use XML::Validator::Schema::ElementRefNode;
use XML::Validator::Schema::RootNode;
use XML::Validator::Schema::ComplexTypeNode;
use XML::Validator::Schema::SimpleTypeNode;
use XML::Validator::Schema::SimpleType;
use XML::Validator::Schema::TypeLibrary;
use XML::Validator::Schema::ElementLibrary;
use XML::Validator::Schema::AttributeLibrary;
use XML::Validator::Schema::ModelNode;
use XML::Validator::Schema::Attribute;
use XML::Validator::Schema::AttributeNode;
use XML::Validator::Schema::Util qw(_err);
our %CACHE;
our $DEBUG = 0;
# create a new validation filter
sub new {
my $pkg = shift;
my $opt = (@_ == 1) ? { %{shift()} } : {@_};
my $self = bless $opt, $pkg;
$self->{debug} = exists $self->{debug} ? $self->{debug} : $DEBUG;
# check options
croak("Missing required 'file' option.") unless $self->{file};
# if caching is on, check the cache
if ($self->{cache} and
exists $CACHE{$self->{file}} and
$CACHE{$self->{file}}{mtime} == (stat($self->{file}))[9]) {
# load cached object
$self->{node_stack} = $CACHE{$self->{file}}{node_stack};
# might have nodes on it leftover from failed validation,
# truncate to root
$#{$self->{node_stack}} = 0;
# clean up any lingering state from the last use of this tree
$self->{node_stack}[0]->walk_down(
{ callback => sub { shift->clear_memory; 1; } });
} else {
# create an empty element stack
$self->{node_stack} = [];
# load the schema, filling in the element tree
$self->parse_schema();
# store to cache
if ($self->{cache}) {
$CACHE{$self->{file}}{mtime} = (stat($self->{file}))[9];
$CACHE{$self->{file}}{node_stack} = $self->{node_stack};
}
}
# buffer text for convenience
my $bf = XML::Filter::BufferText->new( Handler => $self );
# add line-numbers and column-numbers to errors if
# XML::Filter::ExceptionLocator is available
eval { require XML::Filter::ExceptionLocator; };
if ($@) {
# no luck, just return the buffer-text handler
return $bf;
} else {
# create a new exception-locator and return it
my $el = XML::Filter::ExceptionLocator->new( Handler => $bf );
return $el;
}
}
# parse an XML schema document, filling $self->{node_stack}
sub parse_schema {
my $self = shift;
_err("Specified schema file '$self->{file}' does not exist.")
unless -e $self->{file};
# initialize the schema parser
my $parser = XML::Validator::Schema::Parser->new(schema => $self);
# add line-numbers and column-numbers to errors if
# XML::Filter::ExceptionLocator is available
eval { require XML::Filter::ExceptionLocator; };
unless ($@) {
# create a new exception-locator and set it up above the parser
$parser = XML::Filter::ExceptionLocator->new( Handler => $parser );
}
# parse the schema file
$parser = XML::SAX::ParserFactory->parser(Handler => $parser);
$parser->parse_uri($self->{file});
}
# check element start
sub start_element {
my ($self, $data) = @_;
my $name = $data->{LocalName};
my $node_stack = $self->{node_stack};
my $element = $node_stack->[-1];
print STDERR " " x scalar(@{$node_stack}), " o ", $name, "\n"
if $self->{debug};
# check that this alright
my $daughter = $element->check_daughter($name);
# check attributes
$daughter->check_attributes($data->{Attributes});
if ($self->{debug}) {
foreach my $att ( keys %{ $data->{Attributes} } ) {
print STDERR " " x (scalar(@{$node_stack}) + 2), " - ",
$data->{Attributes}->{$att}->{Name}, " = ",
$data->{Attributes}->{$att}->{Value}, "\n"
}
}
# enter daughter node
push(@$node_stack, $daughter);
$self->SUPER::start_element($data);
}
# check character content
sub characters {
my ($self, $data) = @_;
my $element = $self->{node_stack}[-1];
$element->check_contents($data->{Data});
$element->{checked_content} = 1;
$self->SUPER::characters($data);
}
# finish element checking
sub end_element {
my ($self, $data) = @_;
my $node_stack = $self->{node_stack};
my $element = $node_stack->[-1];
# check empty content if haven't checked yet
$element->check_contents('')
unless $element->{checked_content};
$element->{checked_content} = 0;
# final model check
$element->{model}->check_final_model($data->{LocalName},
$element->{memory} || [])
if $element->{model};
# done
$element->clear_memory();
pop(@$node_stack);
$self->SUPER::end_element($data);
}
1;
XML-Validator-Schema-1.10/README 0000644 0000764 0000764 00000005005 10750441343 014227 0 ustar sam sam XML::Validator::Schema version 1.10
CHANGES
- Added a check in Makefile.PL for a broken XML::SAX install.
Hopefully this will convince the legions of CPAN testers with
broken XML::SAX installs to leave me alone.
DESCRIPTION
This module allows you to validate XML documents against a W3C XML
Schema. This module does not implement the full W3C XML Schema
recommendation (http://www.w3.org/XML/Schema), but a useful subset. See
the SCHEMA SUPPORT section in the module documention.
IMPORTANT NOTE: To get line and column numbers in the error
messages generated by this module you must install
XML::Filter::ExceptionLocator and use XML::SAX::ExpatXS as your
SAX parser. This module is much more useful if you can tell where
your errors are, so using these modules is highly recommeded!
RATIONALE
I'm writing a piece of software which uses Xerces/C++ (
http://xml.apache.org/xerces-c/ ) to validate documents against XML
Schema schemas. This works very well, but I'd like to release my project
to the world. Requiring users to install Xerces is simply too onerous a
requirement; few will have it already and the Xerces installation system
leaves much to be desired.
On CPAN, the only available XML Schema validator is XML::Schema.
Unfortunately, this module isn't ready for use as it lacks the ability
to actually parse the XML Schema document format! I looked into
enhancing XML::Schema but I must admit that I'm not smart enough to
understand the code... One day, when XML::Schema is completed I will
replace this module with a wrapper around it.
This module represents my attempt to support enough XML Schema syntax to
be useful without attempting to tackle the full standard. I'm sure this
will mean that it can't be used in all situations, but hopefully that
won't prevent it from being used at all.
INSTALLATION
The easiest way to install this module is using CPAN.pm:
perl -MCPAN -e 'install XML::Validator::Schema'
If you must do it the old-fashioned way, first install:
Carp
Test::More
XML::SAX
Tree::DAG_Node
XML::Filter::BufferText
Then unpack this module's distribution and do:
perl Makefile.PL
make test
make install
AUTHOR
Sam Tregar
COPYRIGHT AND LICENSE
Copyright (C) 2002, 2003, 2004 Sam Tregar
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl 5 itself.
XML-Validator-Schema-1.10/META.yml 0000664 0000764 0000764 00000001147 10750441441 014624 0 ustar sam sam --- #YAML:1.0
name: XML-Validator-Schema
version: 1.10
abstract: validate XML against a subset of W3C XML Schema
license: ~
author:
- Sam Tregar
generated_by: ExtUtils::MakeMaker version 6.42
distribution_type: module
requires:
Carp: 0
Test::More: 0.47
Tree::DAG_Node: 0
XML::Filter::BufferText: 0
XML::SAX: 0.12
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
version: 1.3
XML-Validator-Schema-1.10/MANIFEST.SKIP 0000644 0000764 0000764 00000000055 07737327623 015264 0 ustar sam sam CVS
^Makefile$
^Makefile.old$
^MANIFEST.bak$
XML-Validator-Schema-1.10/ANNOUNCE 0000644 0000764 0000764 00000002614 10747672373 014522 0 ustar sam sam ANNOUNCEMENT: XML::Validator::Schema version 1.09
CHANGES
- Added support for line and column numbers in errors in the schema
file using XML::Filter::ExceptionLocator and XML::SAX::ExpatXS.
- Added support for unions. (John Hollingum)
- Fixed a bug which broke date type checking in Perl v5.10.
- Fixed decimal type to allow values without integer parts like
".45". (Michael Fox)
- Fixed bug where attributes couldn't have anonymous simple-type
definitions. (reported by Jeremy Osborn)
DESCRIPTION
This module allows you to validate XML documents against a W3C XML
Schema. This module does not implement the full W3C XML Schema
recommendation (http://www.w3.org/XML/Schema), but a useful subset. See
the SCHEMA SUPPORT section in the module documention.
IMPORTANT NOTE: To get line and column numbers in the error
messages generated by this module you must install
XML::Filter::ExceptionLocator and use XML::SAX::ExpatXS as your
SAX parser. This module is much more useful if you can tell where
your errors are, so using these modules is highly recommeded!
DOWNLOAD
You can install XML::Validator::Schema from CPAN, or download it
from SourceForge:
http://sourceforge.net/project/showfiles.php?group_id=89764
FULL DOCUMENTATION
Available online:
http://search.cpan.org/~samtregar/XML-Validator-Schema/Schema.pm
XML-Validator-Schema-1.10/MANIFEST 0000644 0000764 0000764 00000003471 10750441441 014504 0 ustar sam sam ANNOUNCE
Changes
Makefile.PL
MANIFEST
MANIFEST.SKIP
README
Schema.pm
Schema/Attribute.pm
Schema/AttributeNode.pm
Schema/AttributeLibrary.pm
Schema/ComplexTypeNode.pm
Schema/ElementLibrary.pm
Schema/ElementNode.pm
Schema/ElementRefNode.pm
Schema/Library.pm
Schema/ModelNode.pm
Schema/Node.pm
Schema/Parser.pm
Schema/RootNode.pm
Schema/SimpleType.pm
Schema/SimpleTypeNode.pm
Schema/TypeLibrary.pm
Schema/Util.pm
t/01basic.t
t/02yaml.t
t/03types.t
t/04model.t
t/05xerces.t
t/06passthru.t
t/all.yml
t/all_min0.yml
t/attribute.yml
t/attribute_ref.yml
t/attribute_types.yml
t/attribute_types2.yml
t/bad_all.yml
t/bad_attribute_type.yml
t/bad_constraint_fractionDigits-totalDigits.yml
t/bad_constraint_length-minLength-maxLength.yml
t/bad_constraint_minLength-less-than-equal-to-maxLength.yml
t/bad_restriction.yml
t/bad_type_fractionDigits.yml
t/bad_type_length.yml
t/bad_type_maxLength.yml
t/bad_type_minLength.yml
t/bad_type_totalDigits.yml
t/choice.yml
t/complex_attr.yml
t/complex_attr2.yml
t/country.yml
t/digits.yml
t/element_ref.yml
t/element_type.yml
t/elementrefintype.yml
t/foo.yml
t/global_type.yml
t/group.yml.todo
t/lib/TestRunner.pm
t/lib/YAML.pm
t/lib/YAML/Error.pm
t/lib/YAML/Family.pm
t/lib/YAML/Node.pm
t/lib/YAML/Transfer.pm
t/media.yml
t/min2max2.yml
t/min_exclusive.yml
t/multi_level.yml
t/multiroot.yml
t/ora_book_1.yml.todo
t/plankton.yml
t/plankton_orig.yml
t/qualified.yml
t/recursive.yml
t/repeated_groups.yml
t/restricted_integer.yml
t/restriction.yml
t/restriction_anon.yml
t/sequence.yml
t/sequence_with_choice.yml
t/simple_content.yml
t/simple_recursion.yml
t/story.yml
t/substring.yml
t/test.xml
t/test.xsd
t/two_level.yml
TODO
t/content_message.yml
t/07locator.t
t/bad.xml
t/bad.xsd
t/bad_union.yml
t/union_test_inline.yml
t/union_test_ref.yml
META.yml Module meta-data (added by MakeMaker)
XML-Validator-Schema-1.10/Changes 0000644 0000764 0000764 00000007173 10750441332 014650 0 ustar sam sam Revision history for XML::Validator::Schema
1.10 2008-01-31
- Added a check in Makefile.PL for a broken XML::SAX install.
Hopefully this will convince the legions of CPAN testers with
broken XML::SAX installs to leave me alone.
1.09 2008-01-29
- Fixed a bug which broke date type checking in Perl v5.10.
- Added support for unions. (John Hollingum)
- Fixed decimal type to allow values like ".45". (Michael Fox)
- Added support for line and column numbers in errors in the schema
file using XML::Filter::ExceptionLocator and XML::SAX::ExpatXS.
- Fixed bug where attributes couldn't have anonymous simple-type
definitions. (reported by Jeremy Osborn)
1.08 2004-11-04
- Added optional support for line and column numbers using
XML::Filter::ExceptionLocator and XML::SAX::ExpatXS.
- Added support for totalDigits and fractionDigits facets of
decimal types, excluding double and float. (Toby Long-Leather)
- Improved content-model validation failure message to include the
name of the enclosing element. (Suggested by Jean Flouret)
1.07 2004-09-22
- New 'debug' option aids in tracking down the source of validation
failures. (Mathieu)
- Fixed bug which prevented minExclusive from working.
(h.bridge@fasol.fujitsu.com)
- Fixed bug which prevented attribute types from working in some
cases.
- Fixed bug which prevented complex types from adding new
attributes to existing complex types. (michael.jacob@schering.de)
1.06 2004-04-21
- Fixed bug in support with minOccurs="0" contents.
(josef@clubphoto.com)
- Fixed bug where minOccurs of 2 or greater wouldn't work
correctly.
- Added support for positiveInteger, negativeInteger,
nonPositiveInteger and nonNegativeInteger. (adamk@ali.as)
- Fixed bug where references to elements inside complex types
wouldn't get resolved.
1.05 2003-11-13
- Added support for more simple types (Russell B Cecala) :
float
duration
time
date
gYearMonth
gYear
gMonthDay
gDay
gMonth
hexBinary
base64Binary
anyURI
QName
NOTATION
1.04 2003-10-06
- Added support for minOccurs and maxOccurs with ,
and .
- Fixed bug in cache implementation that allowed some state from a
failed validation run to leak into subsequent runs.
- Added support for use as a SAX filter anywhere in a SAX pipeline.
1.03 2003-10-03
- Added cache mode to reuse schema objects between calls.
- Added support for more builtin simpleTypes: normalizedString,
token, short, byte, unsignedInt, unsignedShort, unsignedByte
- Added support for element and attribute refs.
- Added support for simpleContent.
- Fixed bug preventing within or
from working.
- Fixed NMTOKEN implementation to derive from token instead of string.
- Fixed bug where test suite would fail if XML::SAX::RTF was
installed.
1.02 2003-10-01
- Added support for composition of and groups.
- Added support for , both named and anonymous, with
mostly complete support.
- Added automated test to run test suite against Xerces/C++ if
available. This should keep our tests in line with expected
reality.
1.01 2003-09-26
- Fixed compatibility with XML::LibXML.
- Modified test suite to run tests against all available SAX parsers.
- Added support for simple and content modules (no
combinations yet).
1.00 2003-09-25
- First Release.
XML-Validator-Schema-1.10/Makefile.PL 0000644 0000764 0000764 00000002307 10750441167 015327 0 ustar sam sam use 5.006;
# make sure XML::SAX isn't broken - if it's just not installed then
if (eval "require XML::SAX") {
my $parsers = XML::SAX->parsers;
unless ($parsers and @$parsers) {
warn < 'XML::Validator::Schema',
VERSION_FROM => 'Schema.pm',
PREREQ_PM => {
'Test::More' => 0.47,
'XML::SAX' => 0.12,
'Carp' => 0,
'Tree::DAG_Node' => 0,
'XML::Filter::BufferText' => 0,
},
ABSTRACT_FROM => 'Schema.pm',
AUTHOR => 'Sam Tregar ');