XML-Compile-1.64/0000755000175000001440000000000014705455321014216 5ustar00markovusers00000000000000XML-Compile-1.64/xt/0000755000175000001440000000000014705455321014651 5ustar00markovusers00000000000000XML-Compile-1.64/xt/99pod.t0000644000175000001440000000041214703742164016001 0ustar00markovusers00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; BEGIN { eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; plan skip_all => "devel home uses OODoc" if $ENV{MARKOV_DEVEL}; } all_pod_files_ok(); XML-Compile-1.64/xt/92json.t0000644000175000001440000001743414705454343016176 0ustar00markovusers00000000000000#!/usr/bin/env perl # test json-friendly conversion use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More; my @json_modules = qw/JSON::XS Cpanel::JSON::XS JSON::PP/; my %has; foreach my $module (@json_modules) { eval "require $module"; $has{$module} = 1 if !$@; } { no warnings 'once'; if($has{'JSON::PP'} && JSON::PP->VERSION < 2.91) { diag "JSON::PP too old, requires 2.91 to work"; delete $has{'JSON::PP'}; } if($has{'JSON::XS'} && JSON::XS->VERSION < 3.02) { diag "JSON::XS too old, requires 3.02 to work"; delete $has{'JSON::XS'}; } if($has{'Cpanel::JSON::XS'} && Cpanel::JSON::XS->VERSION < 3.0201) { diag "Cpanel::JSON::XS too old, requires 3.0201 to work"; delete $has{'Cpanel::JSON::XS'}; } } keys %has or plan skip_all => "No module of the following available: @json_modules"; plan 'no_plan'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $json_serializer; sub test_r_json($$$$;@) { my ($schema, $test, $xml, $expected_json, %args) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; SKIP: { skip "No bignum implementation with " . ref($json_serializer), 1 if $args{need_bignum} && !$json_serializer->can('allow_bignum'); my $type = $test =~ m/\{/ ? $test : "{$TestNS}$test"; my $r = XML::Compile::Tester::reader_create($schema, $test, $type); defined $r or return; my $h = $r->($xml); my $got_json = $json_serializer->encode($h); is $got_json, $expected_json , "json serialization (" . ref($json_serializer) . ") for $test"; } } my @default_compile_defaults = ( elements_qualified => 'NONE' , json_friendly => 1 , sloppy_floats => 1 ); SKIP: foreach my $json_module (@json_modules) { $has{$json_module} or skip "Skip tests with $json_module", 1; diag "Running tests for $json_module"; $json_serializer = $json_module->new->utf8->canonical->allow_nonref; if($json_serializer->can('allow_bignum')) { $json_serializer->allow_bignum; set_compile_defaults @default_compile_defaults; } else { # for JSON::XS (lacks bignum support) set_compile_defaults @default_compile_defaults , sloppy_integers => 1 , sloppy_floats => 1 ; } test_r_json $schema, boolean => '0', 'false'; test_r_json $schema, boolean => 'false', 'false'; test_r_json $schema, boolean => '1', 'true'; test_r_json $schema, boolean => 'true', 'true'; test_r_json $schema, integer => '-123', '-123'; test_r_json $schema, integer => '0', '0'; test_r_json $schema, integer => '123', '123'; test_r_json $schema, long => '-1234', '-1234'; test_r_json $schema, long => '0', '0'; test_r_json $schema, long => '1234', '1234'; test_r_json $schema, long => '1234567890123456789', '1234567890123456789', need_bignum => 1; test_r_json $schema, negativeInteger => '-123', '-123'; test_r_json $schema, nonNegativeInteger => '123', '123'; test_r_json $schema, nonNegativeInteger => '0', '0'; test_r_json $schema, nonPositiveInteger => '-123', '-123'; test_r_json $schema, nonPositiveInteger => '0', '0'; test_r_json $schema, positiveInteger => '123', '123'; test_r_json $schema, unsignedInt => '123', '123'; test_r_json $schema, unsignedLong => '1234567890123456789', '1234567890123456789', need_bignum => 1; test_r_json $schema, byte => '-128', '-128'; test_r_json $schema, byte => '0', '0'; test_r_json $schema, byte => '127', '127'; test_r_json $schema, int => '-2147483648', '-2147483648'; test_r_json $schema, int => '0', '0'; test_r_json $schema, int => '2147483647', '2147483647'; test_r_json $schema, int => '+2147483647', '2147483647'; test_r_json $schema, short => '-32768', '-32768'; test_r_json $schema, short => '0', '0'; test_r_json $schema, short => '32767', '32767'; test_r_json $schema, 'unsignedByte', '0', '0'; test_r_json $schema, 'unsignedByte', '255', '255'; # Currently broken # test_r_json $schema, 'decimal', '-99999999999999999999.9999', '-99999999999999999999.9999', need_bignum => 1; test_r_json $schema, 'decimal', '-123.4560', '-123.456'; # trailing zero gets lost! test_r_json $schema, 'decimal', '-123.456', '-123.456'; test_r_json $schema, 'decimal', '-123', '-123'; test_r_json $schema, 'decimal', '0', '0'; # Depends on the JSON parser # test_r_json $schema, 'decimal', '0.0', '0.0'; # XXX .0 gets lost! test_r_json $schema, 'decimal', '123', '123'; test_r_json $schema, 'decimal', '123.456', '123.456'; test_r_json $schema, 'decimal', '123.4560', '123.456'; # Currently broken # test_r_json $schema, 'decimal', '99999999999999999999.9999', '99999999999999999999.9999', need_bignum => 1; test_r_json $schema, 'float', '123.4560', '123.456'; test_r_json $schema, 'float', '-123.4560', '-123.456'; TODO: { local $TODO = "NaN/inf support partially buggy"; # see https://github.com/rurban/Cpanel-JSON-XS/issues/78 # JSON::XS has no option to prevent NaN/inf generation test_r_json $schema, 'float', 'NaN', 'null'; # no Nan/Inf... support in JSON test_r_json $schema, 'float', '-INF', 'null'; # no Nan/Inf... support in JSON test_r_json $schema, 'float', '+INF', 'null'; # no Nan/Inf... support in JSON } test_r_json $schema, 'string', '', '""'; test_r_json $schema, 'string', 'non-empty', '"non-empty"'; test_r_json $schema, 'string', '€', qq{"\342\202\254"}; # euro sign test_r_json $schema, 'complex', '', '{}'; test_r_json $schema, 'complex', '12', '{"elem":[1,2]}'; } XML-Compile-1.64/html/0000755000175000001440000000000014705455321015162 5ustar00markovusers00000000000000XML-Compile-1.64/html/other/0000755000175000001440000000000014705455321016303 5ustar00markovusers00000000000000XML-Compile-1.64/html/other/manuals/0000755000175000001440000000000014705455321017743 5ustar00markovusers00000000000000XML-Compile-1.64/html/other/manuals/head.html0000644000175000001440000000121214703742164021530 0ustar00markovusers00000000000000 <!--{project}-->; All Manuals
XML::Compile
Documentation
version ,


All Manuals

 all manuals
all methods and functions
all diagnostics
all details
XML-Compile-1.64/html/other/manuals/index.html0000644000175000001440000000050114703742164021736 0ustar00markovusers00000000000000 <!--{project}-->; All Methods <body> Sorry, you need frames for this documentation. </body> XML-Compile-1.64/html/other/manuals/list.html0000644000175000001440000000056314703742164021612 0ustar00markovusers00000000000000 <!--{project}--> Manuals
Mark Overmeer. Documentation of XML::Compile version , produced . XML-Compile-1.64/html/other/details/0000755000175000001440000000000014705455321017730 5ustar00markovusers00000000000000XML-Compile-1.64/html/other/details/index.html0000644000175000001440000000136014703742164021727 0ustar00markovusers00000000000000 <!--{project}-->; All Details
XML::Compile
Documentation
version ,


All details

 all manuals
all methods and functions
all diagnostics
all details

All detailed documentation sections:

XML-Compile-1.64/html/other/methods/0000755000175000001440000000000014705455321017746 5ustar00markovusers00000000000000XML-Compile-1.64/html/other/methods/index.html0000644000175000001440000000144014703742164021744 0ustar00markovusers00000000000000 <!--{project}-->; All Methods
XML::Compile
Documentation
version ,


Methods and Functions

 all manuals
all methods and functions
all  diagnostics
all details

Methods and functions, merged and alphabetically ordered.

XML-Compile-1.64/html/other/xml.css0000644000175000001440000000040314703742164017614 0ustar00markovusers00000000000000 BODY { font-family: Arial, Herlvetica, sans-serif } H2 { font-variant: small-caps; } A:link { color: green; text-decoration: none; } A:visited { color: blue; text-decoration: none; } UL { margin-top: 0; } DL { margin-top: 1ex; } XML-Compile-1.64/html/other/index.html0000644000175000001440000000277614703742164020316 0ustar00markovusers00000000000000 <!--{project}--> <!--{version}-->

XML::Compile can be used to translate a Perl data-structure into XML or XML into a Perl data-structure, both directions under rigid control by a schema

A good starting-point is method compile(), called on a XML::Compile::Schema object.

all manuals
A list of all manuals included in XML::Compile.
all methods
An overview of all methods, arranged alphabetically
all diagnostics
A list of all diagnostics which can be produced by this module. Often useful to determine which method is complaining about a mistake.
all details
Many manual pages contain a DETAILS chapter which explains all kinds of facts about the general background, implementation specifics, and examples of complex use of the items. Looking through the full list of details may help to find a solution.
Mark Overmeer. Documentation of XML::Compile version , produced with XML::Compile on .
XML-Compile-1.64/html/other/jump.cgi0000644000175000001440000000267014703742164017751 0ustar00markovusers00000000000000#!/usr/bin/perl -T use strict; use warnings; print "Content-Type: text/html\r\n\r\n"; # Get the question my $to = $ENV{QUERY_STRING} || ''; my ($manual, $unique) = $to =~ m/([\w:%]+)\&(\d+)/; $manual =~ s/\%[a-fA-F0-9]{2}/chr hex $1/ge; # Contact the database my $DB = $0; $DB =~ s/[\w\.]+$/markers/; open DB, '<', $DB or die "Cannot read markers from $DB: $!\n"; my $root = ; chomp $root; # Lookup location of item in the manual page my ($nr, $in, $page); while( ) { ($nr, $in, $page) = split " ", $_, 3; last if $nr eq $unique && $in eq $manual; } die "Cannot find id $to for $manual in $DB.\n" unless $nr eq $unique; chomp $page; # Keep same index on the right, if possible my $show = "relations.html"; if(my $refer = $ENV{HTTP_REFERER}) { $show = "$1.html" if $refer =~ m/(doclist|sorted|grouped|relations)\.html/; } # Produce page, which is compible to the normal html/manual/index.html # This cgi script is processed by the template system too. print < $manual <body> Sorry, you need frames for this documentation. </body> PAGE XML-Compile-1.64/html/other/diagnostics/0000755000175000001440000000000014705455321020612 5ustar00markovusers00000000000000XML-Compile-1.64/html/other/diagnostics/index.html0000644000175000001440000000145014703742164022611 0ustar00markovusers00000000000000 <!--{project}-->; All Diagnostics
XML::Compile
Documentation
version ,


All Diagnostics

 all manuals
all methods and functions
all diagnostics
all details

errors

warnings

XML-Compile-1.64/html/manual/0000755000175000001440000000000014705455321016437 5ustar00markovusers00000000000000XML-Compile-1.64/html/manual/relations.html0000644000175000001440000000056114703742164021331 0ustar00markovusers00000000000000 <!--{title}--> Show XML-Compile-1.64/html/manual/grouped.html0000644000175000001440000000075214703742164021000 0ustar00markovusers00000000000000 <!--{title}--> Show XML-Compile-1.64/html/manual/sorted.html0000644000175000001440000000120414703742164020624 0ustar00markovusers00000000000000 <!--{title}--> Show Overloaded:
Methods:
Functions:
XML-Compile-1.64/html/manual/index.html0000644000175000001440000000064514703742164020443 0ustar00markovusers00000000000000 <!--{title}--> <body> Sorry, you need frames for this documentation. </body> XML-Compile-1.64/html/manual/head.html0000644000175000001440000000121214703742164020224 0ustar00markovusers00000000000000 <!--{title}-->
XML::Compile
Documentation
version ,


all manuals
all methods and functions
all diagnostics
all details
XML-Compile-1.64/html/manual/methods.html0000644000175000001440000000105114703742164020767 0ustar00markovusers00000000000000 <!--{title}--> XML-Compile-1.64/html/manual/doclist.html0000644000175000001440000000110614703742164020766 0ustar00markovusers00000000000000 <!--{title}--> Show XML-Compile-1.64/html/manual/main.html0000644000175000001440000000041614703742164020254 0ustar00markovusers00000000000000 <!--{title}--> XML-Compile-1.64/t/0000755000175000001440000000000014705455321014461 5ustar00markovusers00000000000000XML-Compile-1.64/t/01use.t0000644000175000001440000000364314703742164015613 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib'; use Test::More tests => 13; # The versions of the following packages are reported to help understanding # the environment in which the tests are run. This is certainly not a # full list of all installed modules. my @show_versions = qw/Test::More Test::Deep Log::Report Math::BigInt String::Print XML::LibXML XML::Compile XML::Compile::SOAP XML::Compile::Tester XML::Compile::Dumper XML::Compile::Cache /; foreach my $package (@show_versions) { eval "require $package"; no strict 'refs'; my $report = !$@ ? "version ". (${"$package\::VERSION"} || 'unknown') : $@ =~ m/^Can't locate/ ? "not installed" : "reports error"; warn "$package $report\n"; } my $xml2_version = XML::LibXML::LIBXML_DOTTED_VERSION(); warn "libxml2 $xml2_version\n"; my ($major,$minor,$rev) = split /\./, $xml2_version; if( $major < 2 || ($major==2 && $minor < 6) || ($major==2 && $minor==6 && $rev < 23)) { warn <<__WARN; * * WARNING: * Your libxml2 version ($xml2_version) is quite old: you may * have failing tests and poor functionality. * * Please install a new version of the library AND reinstall the * XML::LibXML module. Otherwise, you may need to install this * module with force. * __WARN warn "Press enter to continue with the tests: \n"; ; } require_ok('XML::Compile'); require_ok('XML::Compile::Iterator'); require_ok('XML::Compile::Schema'); require_ok('XML::Compile::Schema::BuiltInFacets'); require_ok('XML::Compile::Schema::BuiltInTypes'); require_ok('XML::Compile::Schema::Instance'); require_ok('XML::Compile::Schema::NameSpaces'); require_ok('XML::Compile::Schema::Specs'); require_ok('XML::Compile::Translate'); require_ok('XML::Compile::Translate::Reader'); require_ok('XML::Compile::Translate::Writer'); require_ok('XML::Compile::Translate::Template'); require_ok('XML::Compile::Util'); XML-Compile-1.64/t/49list.t0000644000175000001440000000505314703742164016003 0ustar00markovusers00000000000000#!/usr/bin/env perl # simpleType list use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 124; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA ); __SCHEMA ok(defined $schema); test_rw($schema, test1 => <<__XML, [1]); 1 __XML test_rw($schema, test1 => <<__XML, [0]); 0 __XML test_rw($schema, test1 => <<__XML, [0, 0]); 0 0 __XML test_rw($schema, test1 => <<__XML, [2, 3]); 2 3 __XML test_rw($schema, test1 => <<__XML, [4, 5, 6]); 4 5\t 6 __XML test_rw($schema, test2 => <<__XML, [1]); 1 __XML test_rw($schema, test2 => <<__XML, [2, 3]); 2 3 __XML test_rw($schema, test2 => <<__XML, [0, 0]); 0 0 __XML test_rw($schema, test2 => <<__XML, [4, 5, 6]); 4 5\t 6 __XML test_rw($schema, test2 => <<__XML, []); __XML # restriction on simple-list base test_rw($schema, test3 => <<__XML, [1, 2]); 1 2 __XML test_rw($schema, test3 => <<__XML, [2, 1]); 2 1 __XML my $error = error_r($schema, test3 => '2 2'); is($error, "invalid enumerate `2 2' at {http://test-types}test3#facet"); $error = error_w($schema, test3 => [3, 3]); is($error, "invalid enumerate `3 3' at {http://test-types}test3#facet"); # predefined test_rw($schema, test4 => <<__XML, [3, 4]); 3 4 __XML $error = error_w($schema, test4 => [3, 3]); is($error, "invalid enumerate `3 3' at {http://test-types}test4#facet"); # element has attributes as well my $w1 = writer_create($schema, "HASH param" => "{$TestNS}test1"); my $x1 = writer_test($w1, {_ => [7,8]}); compare_xml($x1->toString, <<'_XML'); 7 8 _XML XML-Compile-1.64/t/57fixed.t0000644000175000001440000000436114703742164016127 0ustar00markovusers00000000000000#!/usr/bin/env perl # test use element fixed use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 48; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); ## ### Fixed Integers ## Big-ints are checked in 49big.t test_rw($schema, test1 => <<__XML, {t1a => 'not-changeable', t1c => 42}); not-changeable __XML my $r1 = reader_create $schema, 'missing fixed reader', "{$TestNS}test1"; isa_ok($r1, 'CODE'); my $h1 = $r1->('12'); is_deeply($h1, {t1b => 12, t1a => 'not-changeable', t1c => 42}); my $w1 = writer_create $schema, 'missing fixed writer', "{$TestNS}test1"; isa_ok($w1, 'CODE'); my $x1 = writer_test $w1, {t1b => 13}; compare_xml $x1, '13'; my %t1c = (t1a => 'wrong', t1b => 12, t1c => 42); my $error = error_w($schema, test1 => \%t1c); is($error, "element `t1a' has value fixed to `not-changeable', got `wrong' at {http://test-types}test1/t1a"); # # Optional fixed integers # my %t2a = (t2a => 14, t2b => 13); test_rw($schema, test2 => <<__XML, \%t2a); __XML $error = error_r($schema, test2 => <<__XML); __XML is($error, "value of attribute `t2b' is fixed to `13', not `12' at {http://test-types}test2/\@t2b"); my %t2b = (t2a => 15, t2b => 12); $error = error_w($schema, test2 => \%t2b); is($error, "value of attribute `t2b' is fixed to `13', not `12' at {http://test-types}test2/\@t2b"); my %t2c = (t2a => 17, t2b => 13); test_rw($schema, test2 => <<__XML, \%t2c); __XML XML-Compile-1.64/t/22call.t0000644000175000001440000000222214703742164015725 0ustar00markovusers00000000000000#!/usr/bin/env perl # Try different calling convensions (::Tester is only using one) # A few options are not formally tested; hopefully in the future. # This script should work before any output of the other tests # starts to be useful. use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; #use Log::Report mode => 3; use Test::More tests => 11; my $schema = XML::Compile::Schema->new( <<__SCHEMA ); __SCHEMA ok(defined $schema); ### ### ComplexType writer ### my $w1 = writer_create $schema, "complexType writer", 'test1'; my $xml1 = writer_test $w1, {t1e1 => 12, t1e2 => 13}; compare_xml($xml1, <<__EXPECT); 12 13 __EXPECT ### ### SimpleType writer ### my $w2 = writer_create $schema, "simpleType writer", 'test2'; my $xml2 = writer_test $w2, 14; compare_xml($xml2, '14'); XML-Compile-1.64/t/74qname.t0000644000175000001440000000367114703742164016133 0ustar00markovusers00000000000000#!/usr/bin/env perl # QName builtins are harder, because they need the node which is processed # to lookup the name-space. use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 33; set_compile_defaults elements_qualified => 'NONE'; my $NS2 = "http://test2/ns"; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my %prefixes = ( $TestNS => { prefix => '', uri => $TestNS } , $NS2 => { prefix => 'two', uri => $NS2, used => 1 } ); set_compile_defaults include_namespaces => 1 , prefixes => \%prefixes; ### QName direct test_rw($schema, test1 => <<__TRY1, "{$NS2}aaa"); two:aaa __TRY1 ### QName in LIST $prefixes{$NS2}{used} = 1; test_rw($schema, test2 => <<__TRY2, [ "{$NS2}aaa", "{$NS2}bbb" ]); two:aaa two:bbb __TRY2 ### QName extended $prefixes{$NS2}{used} = 1; test_rw($schema, test3 => <<__TRY3, "{$NS2}aaa"); two:aaa __TRY3 ### QName union $prefixes{$NS2}{used} = 1; test_rw($schema, test4 => <<__TRY4, "{$NS2}aaa"); two:aaa __TRY4 XML-Compile-1.64/t/21types.t0000644000175000001440000000651414703742164016165 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Math::BigFloat; use Test::More tests => 175; use utf8; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); set_compile_defaults elements_qualified => 'NONE'; ### ### int ### test_rw($schema, test1 => '0', 0); test_rw($schema, test1 => '3', 3); ### ### Boolean ### test_rw($schema, test2 => '0', 0); test_rw($schema, test2 => 'false', 0 , 'false', 'false'); test_rw($schema, test2 => '1', 1); test_rw($schema, test2 => 'true', 1 , 'true', 'true'); ### ### Float ### test_rw($schema, test3 => '0', 0); test_rw($schema, test3 => '9', 9); test_rw($schema, test3 => 'INF', Math::BigFloat->binf); test_rw($schema, test3 => '-INF', Math::BigFloat->binf('-')); test_rw($schema, test3 => 'NaN', Math::BigFloat->bnan); my $error = error_r($schema, test3 => ''); is($error, "illegal value `' for type {http://www.w3.org/2001/XMLSchema}float at {http://test-types}test3"); $error = error_w($schema, test3 => 'aap'); is($error, "illegal value `aap' for type {http://www.w3.org/2001/XMLSchema}float at {http://test-types}test3"); $error = error_w($schema, test3 => ''); is($error, "illegal value `' for type {http://www.w3.org/2001/XMLSchema}float at {http://test-types}test3"); ### test_rw($schema, test4 => 'A bc D', [ qw/A bc D/ ]); ### ### Integers ### test_rw($schema, test5 => '4320239', 4320239); ### ### Base64Binary ### test_rw($schema,test6 => 'SGVsbG8sIFdvcmxkIQ==','Hello, World!'); $error = error_w($schema, test6 => "€"); is($error, 'use Encode::encode() for base64Binary field at {http://test-types}test6'); ### ### dateTime validation ### my $d = '2010-02-11T08:52:47'; test_rw($schema, test7 => "$d", $d); ### ### duration validation ### my $e = 'PT5M'; test_rw($schema, test8 => "$e", $e); ### ### hexBinary ### my $f = pack "N", 0x12345678; test_rw($schema, test9 => "12345678", $f); ### ### string ### test_rw($schema, testA => "abc", 'abc'); my $r1 = reader_create $schema, "CDATA reader" => "{$TestNS}testA"; my $cd = ''; my $r1a = $r1->($cd); cmp_ok($r1a, 'eq', 'abc'); my $cdata = XML::LibXML::CDATASection->new('abc'); is('', $cdata->toString(1)); #XXX MO 20120815: XML::LibXML crashed on cleanup of double refs to CDATA # object (as done in clone of test_rw). Other XML::LibXML objects do not # crash on this. #test_rw($schema, testA => $cd, 'abc', $cd, $cdata); test_rw($schema, testA => '', ''); XML-Compile-1.64/t/55facet.t0000644000175000001440000003044114703742164016106 0ustar00markovusers00000000000000#!/usr/bin/env perl # test facets use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use XML::Compile::Util qw/pack_type/; use Test::More tests => 392; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); # # ## ### Integers ## test_rw($schema, test1 => <<__XML, 12); 12 __XML test_rw($schema, test2 => <<__XML, 13); 13 __XML test_rw($schema, test2 => <<__XML, 42); 42 __XML my $error = error_r($schema, test2 => <<__XML); 43 __XML is($error, "too large inclusive 43, max 42 at {http://test-types}test2#facet"); $error = error_w($schema, test2 => 43); is($error, "too large inclusive 43, max 42 at {http://test-types}test2#facet"); $error = error_r($schema, test2 => <<__XML); 11 __XML is($error, "too small inclusive 11, min 12 at {http://test-types}test2#facet"); $error = error_w($schema, test2 => 11); is($error, "too small inclusive 11, min 12 at {http://test-types}test2#facet"); test_rw($schema, "test3" => <<__XML, 44); 44 __XML $error = error_r($schema, test3 => <<__XML); 45 __XML is($error, "too large exclusive 45, smaller 45 at {http://test-types}test3#facet"); $error = error_w($schema, test3 => 45); is($error, "too large exclusive 45, smaller 45 at {http://test-types}test3#facet"); $error = error_r($schema, test3 => <<__XML); 13 __XML is($error, "too small exclusive 13, larger 13 at {http://test-types}test3#facet"); $error = error_w($schema, test3 => 13); is($error, "too small exclusive 13, larger 13 at {http://test-types}test3#facet"); ## ### strings ## test_rw($schema, "test4" => <<__XML, "aap"); aap __XML $error = error_r($schema, test4 => <<__XML); noot __XML is($error, "string `noot' does not have required length 3 but 4 at {http://test-types}test4\#facet"); $error = error_w($schema, test4 => 'noot'); is($error, "string `noot' does not have required length 3 but 4 at {http://test-types}test4\#facet"); $error = error_r($schema, test4 => <<__XML); ik __XML is($error, "string `ik' does not have required length 3 but 2 at {http://test-types}test4#facet"); $error = error_w($schema, test4 => "ik"); is($error, "string `ik' does not have required length 3 but 2 at {http://test-types}test4#facet"); test_rw($schema, "test5" => <<__XML, "\ \ \t\n\tmies \t"); \ \ \t \tmies \t __XML test_rw($schema, "test6" => <<__XML, " mies ", <<__XML, "\ \ \t \tmies \t"); \ \ \t \tmies \t __XML mies __XML test_rw($schema, "test7" => <<__XML, 'mies', <<__XML, "\ \ \t \tmies \t"); \ \ \t \tmies \t __XML mies __XML test_rw($schema, "test8" => <<__XML, 'one'); one __XML test_rw($schema, "test8" => <<__XML, 'two'); two __XML $error = error_r($schema, test8 => <<__XML); three __XML is($error, "invalid enumerate `three' at {http://test-types}test8#facet"); $error = error_r($schema, test8 => <<__XML); __XML is($error, "invalid enumerate `' at {http://test-types}test8#facet"); ### test9 (bug reported by Gert Doering) set_compile_defaults sloppy_integers => 1 , sloppy_floats => 1 , elements_qualified => 'NONE'; test_rw($schema, test9 => '0', 0); test_rw($schema, test9 => '12', 12); test_rw($schema, test9 => '123', 123); test_rw($schema, test9 => '1234', 1234); $error = error_w($schema, test9 => 12345); is($error, 'decimal too long, got 5 digits max 4 at {http://test-types}test9#facet'); $error = error_r($schema, test9 => '12345'); is($error, 'decimal too long, got 5 digits max 4 at {http://test-types}test9#facet'); ### test10 (same bug reported by Gert Doering) test_rw($schema, test10 => '0', 0); test_rw($schema, test10 => '1.2', 1.2); test_rw($schema, test10 => '1.23', 1.23); test_rw($schema, test10 => '12.3', 12.3); test_rw($schema, test10 => '1.234', 1.234); test_rw($schema, test10 => '12.34', 12.34); test_rw($schema, test10 => '123.4', 123.4); test_rw($schema, test10 => '1234', 1234); ### test11 (from bug reported by Allan Wind) $error = error_w($schema, test11 => {t11 => 3}); is($error, 'too small inclusive 3, min 12 at {http://test-types}test11/t11#facet'); ### test12 rt.cpan.org#39224 test_rw($schema, test12 => '1.12', '1.12'); test_rw($schema, test12 => '1.10', '1.10'); test_rw($schema, test12 => '1.00', '1.00'); test_rw($schema, test12 => '1.2', '1.2'); test_rw($schema, test12 => '1.', '1.'); $error = error_r($schema, test12 => '1'); like($error, qr/^string \`1' does not match pattern /); # dot problem with regex '.' $error = error_r($schema, test12 => '42'); like($error, qr/^string \`42' does not match pattern /); ### test13 length on base64 test_rw($schema, test13 => 'YWJjZGU=', 'abcde'); $error = error_r($schema, test13 => 'YWJjYWJjZGU='); is($error, "string `abcabcde' does not have required length 5 but 8 at {http://test-types}test13#facet"); $error = error_w($schema, test13 => 'abcdef'); is($error, "string `abcdef' does not have required length 5 but 6 at {http://test-types}test13#facet"); ### test14 enumeration of qnames [Aleksey Mashanov] set_compile_defaults include_namespaces => 1 , use_default_namespace => 0 , prefixes => [ a => $TestNS ]; test_rw($schema, test14 => qq{a:Sender} , "{$TestNS}Sender"); ### test15 length of hexBinary test_rw($schema, test15 => qq{DEADBEEF}, pack('N', 0xdeadbeef)); $error = error_r($schema, test15 => qq{345678}); is($error, "string `4Vx' does not have required length 4 but 3 at a:test15#facet"); $error = error_w($schema, test15 => 'abc'); is($error, "string `abc' does not have required length 4 but 3 at a:test15#facet"); $error = error_w($schema, test15 => 'anything'); is($error, "string `anything' does not have required length 4 but 8 at a:test15#facet"); ### test16 fracDigits # max 2 digits my $t16 = pack_type $TestNS, 'test16'; my $r16 = reader_create $schema, "frac 2r", $t16; is($r16->(qq{2.14}), "2.14"); is($r16->(qq{3.1}), "3.1"); is($r16->(qq{3.14152}), "3.14"); my $w16 = writer_create $schema, 'frac 2w', $t16; my $x16 = writer_test $w16, '3.141526'; compare_xml($x16, qq{3.14}); ### test17, totalFracDigits [mimon-cz] my $t17 = pack_type $TestNS, 'test17'; my $r17 = reader_create $schema, "total 5, frac 2r", $t17; is($r17->(qq{2.14}), "2.14"); is($r17->(qq{3.1}), "3.1"); $error = error_r($schema, test17 => qq{3.14152}); is($error, 'fractional part for 3.14152 too long, got 5 digits max 2 at a:test17#facet'); my $w17 = writer_create $schema, 'total 5, frac 2w', $t17; my $x17 = writer_test $w17, '3.14'; compare_xml($x17, qq{3.14}); ### test18 canonicalization and patterns my $t18 = pack_type $TestNS, 'test18'; my $r18 = reader_create $schema, "canon patterns", $t18; is($r18->(qq{0519}), '0519'); my $w18 = writer_create $schema, 'canon patterns', $t18; my $x18 = writer_test $w18, '0519'; compare_xml($x18, qq{0519}); ### test19 canonicalization and patterns, multiple facets my $t19 = pack_type $TestNS, 'test19'; my $r19 = reader_create $schema, "canon patterns multi", $t19; is($r19->(qq{14}), '14'); is($r19->(qq{03}), '03'); $error = error_r($schema, test19 => qq{124}); is($error, "invalid enumerate `124' at a:test19#facet"); my $w19 = writer_create $schema, 'canon patterns multi', $t19; my $x19a = writer_test $w19, '14'; compare_xml($x19a, qq{14}); my $x19b = writer_test $w19, '03'; compare_xml($x19b, qq{03}); XML-Compile-1.64/t/75type.t0000644000175000001440000000570214703742164016011 0ustar00markovusers00000000000000#!/usr/bin/env perl # test the handling of xsi:type use warnings; use strict; use lib 'lib', 't'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use XML::Compile::Util 'SCHEMA2001i'; my $schema2001i = SCHEMA2001i; use Test::More tests => 26; #use Log::Report mode => 3; my %xsi_types = ("{$TestNS}f_t1" => [ "{$TestNS}f_t2" ] ); set_compile_defaults include_namespaces => 1 , xsi_type => \%xsi_types; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my %f1 = (f_a3 => [ { XSI_TYPE => "{$TestNS}f_t2" , f_a1 => 18, , f_a2 => 4 } , { XSI_TYPE => "{$TestNS}f_t1" , f_a1 => 19 } ] ); test_rw($schema, "f_test" => <<__XML, \%f1); 4 __XML my $out = templ_perl $schema, "{$TestNS}f_test" , xsi_type => \%xsi_types, skip_header => 1; is($out, <<'__TEMPL'); # Describing complex x0:f_test # {http://test-types}f_test # is an unnamed complex { # sequence of f_a3 # xsi:type alternatives: # x0:f_t1 # x0:f_t2 # occurs any number of times f_a3 => [ { XSI_TYPE => 'x0:f_t1', %data }, ], } __TEMPL # ### test auto-detection of xsi-elements # set_compile_defaults include_namespaces => 1 , xsi_type => {"{$TestNS}f_t1" => 'AUTO'}; test_rw($schema, "f_test" => <<__XML, \%f1); 4 __XML # ### Bug reported by Lars Thegler, 2013-01-15 # set_compile_defaults include_namespaces => 1 , xsi_type => {"{$TestNS}f_t1" => 'AUTO'}; my %f2 = (f_e4 => [ { XSI_TYPE => "{$TestNS}f_t2" , f_a1 => 20, , f_a2 => 21 } , { XSI_TYPE => "{$TestNS}f_t1" , f_a1 => 22 } ] , size => 23 ); test_rw($schema, "f4" => <<__XML, \%f2); 21 23 __XML XML-Compile-1.64/t/41choice.t0000644000175000001440000002040714703742164016252 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 236; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); test_rw($schema, test1 => <<__XML, {t1_a => 10}); 10 __XML my $error = error_r($schema, test1 => <<__XML); 89 __XML is($error, "element `extra' not processed for {http://test-types}test1 at /test1/extra"); # choice itself is not a choice, unless minOccurs=0 $error = error_r($schema, test1 => <<__XML); __XML is($error, "element `t1_a' expected for choice at {http://test-types}test1"); test_rw($schema, test2 => <<__XML, {t2_a => 11}); 11 __XML # test 3 test_rw($schema, test3 => <<__XML, {t3_a => 13}); 13 __XML test_rw($schema, test3 => <<__XML, {t3_b => 14}); 14 __XML test_rw($schema, test3 => <<__XML, {t3_c => 15}); 15 __XML # test 4 test_rw($schema, test4 => <<__XML, {t4_a => 16}); 16 __XML test_rw($schema, test4 => <<__XML, {t4_b => 17, t4_c => 18}); 1718 __XML test_rw($schema, test4 => <<__XML, {t4_d => 19}); 19 __XML # test 5 test_rw($schema, test5 => <<__XML, {cho_t5_a => [ {t5_a => 20} ]} ); 20 __XML test_rw($schema, test5 => <<__XML, {cho_t5_a => [ {t5_b => 21} ]} ); 21 __XML test_rw($schema, test5 => <<__XML, {cho_t5_a => [ {t5_c => 22} ]} ); 22 __XML my %t5_a = ( cho_t5_a => [ {t5_a => 23} , {t5_b => 24} , {t5_c => 25} ] ); test_rw($schema, test5 => <<__XML, \%t5_a); 232425 __XML my %t5_b = ( cho_t5_a => [ {t5_a => 30} , {t5_a => 31} , {t5_c => 32} , {t5_a => 33} ] ); test_rw($schema, test5 => <<__XML, \%t5_b); 30313233 __XML test_rw($schema, test5 => '', {}); # test 6 test_rw($schema, test6 => <<__XML, {cho_t6_a => [ {t6_b => 10} ]} ); 10 __XML $error = error_r($schema, test6 => ''); is($error, "no element left to pick choice at {http://test-types}test6"); $error = error_w($schema, test6 => {}); is($error, "found 0 blocks for `cho_t6_a', must be between 1 and 3 inclusive at {http://test-types}test6"); $error = error_r($schema, test6 => <<__XML); 30313233 __XML is($error, "element `t6_a' not processed for {http://test-types}test6 at /test6/t6_a[3]"); my %t6_b = ( cho_t6_a => [ {t6_a => 30} , {t6_a => 31} , {t6_c => 32} , {t6_a => 33} ] ); $error = error_w($schema, test6 => \%t6_b); is($error, "found 4 blocks for `cho_t6_a', must be between 1 and 3 inclusive at {http://test-types}test6"); # test 7 ## the other group comes first, for writer test_rw($schema, test7 => <<__XML, {g7e1 => 12, g7e2 => 13}, <<__XML ); 1312 __XML 1213 __XML test_rw($schema, test7 => <<__XML, {g7e1 => 14, g7e2 => 15} ); 1415 __XML # test 8 test_rw($schema, test8 => <<__XML, { t8a => 16 }); 16 __XML test_rw($schema, test8 => <<__XML, { }); # match minOccurs=0! __XML # test 9 my @t9 = { t9a => {}, t9b => 'monkey'}; test_rw($schema, test9 => <<__XML, { seq_t9a => \@t9 }); monkey __XML push @t9, { t9a => {}, t9b => 'donkey' }; test_rw($schema, test9 => <<__XML, { seq_t9a => \@t9 }); monkey donkey __XML test_rw($schema, test9 => <<__XML, { t9c => 42 }); 42 __XML # test10 test_rw($schema, test10 => <<__XML, { t10a => 3, t10b => 4, t10d => 5 }); 3 4 5 __XML test_rw($schema, test10 => <<__XML, { t10a => 6, t10d => 7 }); 6 7 __XML # test11, nested choice my $out = templ_perl($schema, "{$TestNS}test11", show => 'ALL' , skip_header => 1, , prefixes => [ 'me' => $TestNS ] ); is($out, <<__TEST11); # Describing complex me:test11 # {http://test-types}test11 # is an unnamed complex { # choice of cho_t11a, t11c # choice of t11a, t11b # occurs 1 <= # <= unbounded times cho_t11a => [ { # is a xs:int t11a => 42, # is a xs:int t11b => 42, }, ], # is a xs:int t11c => 42, } __TEST11 my $t11 = { cho_t11a => [ {t11a => 3},{t11b => 4},{t11b => 5},{t11a => 6} ]}; test_rw($schema, test11 => <<__XML, $t11); 3 4 5 6 __XML test_rw($schema, test11 => <<__XML, {t11c => 7} ); 7 __XML XML-Compile-1.64/t/90nons.t0000644000175000001440000000311514703742164015776 0ustar00markovusers00000000000000#!/usr/bin/env perl # Test schemas unqualified schemas without target-namespace use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 27; set_compile_defaults elements_qualified => 'NONE'; # elementFormDefault just to add confusion. my $schema = XML::Compile::Schema->new( <<__SCHEMA); __SCHEMA ok(defined $schema); is(join("\n", join "\n", $schema->types)."\n", "ct1\n"); is(join("\n", join "\n", $schema->elements)."\n", <<__ELEMS__); test1 test2 test4 __ELEMS__ test_rw($schema, "{}test1" => <<__XML, 10); 10 __XML test_rw($schema, "{}test2" => <<__XML, {c1_a => 11}); 11 __XML my %t4 = (c1_a => 14, a1_a => 15, c4_a => 16, a4_a => 17); test_rw($schema, "{}test4" => <<__XML, \%t4); 14 16 __XML XML-Compile-1.64/t/44ctext.t0000644000175000001440000000226614703742164016155 0ustar00markovusers00000000000000#!/usr/bin/env perl # test complex type extensions use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 9; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my %t1 = (t1_a => 11, t1_b => 12, a1_a => 13, a1_b => 14, t2_a => 15, a2_a=>16); test_rw($schema, "test1" => <<__XML__, \%t1); 11 12 15 __XML__ XML-Compile-1.64/t/62recurse.t0000644000175000001440000000466314703742164016501 0ustar00markovusers00000000000000#!/usr/bin/env perl # Recursive schemas use warnings; use strict; use lib 'lib','t'; use TestTools; use Data::Dumper; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 65; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); # this is not recursion # ... neither is this one __SCHEMA__ ok(defined $schema); ### test 1, recursive element test_rw($schema, test1 => <<__XML, {count => 1}); 1 __XML test_rw($schema, test1 => <<__XML, {count => 1, test1 => {count => 2}}); 2 1 __XML test_rw($schema, test1 => <<__XML, {count => 1, test1 => {count => 2, test1 => {count => 3}}}); 3 2 1 __XML ### test 2, recursive type test_rw($schema, test2 => <<__XML, {a => 4}); 4 __XML test_rw($schema, test2 => <<__XML, {a => 5, b => {a => 6}}); 5 6 __XML test_rw($schema, test2 => <<__XML, {a => 7, b => {a => 8, b => {a => 9}}}); 7 8 9 __XML ### test 3, no recursion [when detected as recursion, you get errors] test_rw($schema, test3 => <<__XML, { c => { c => 42 } } ); 42 __XML ### test 4, no recursion test_rw($schema, test4 => <<__XML, { test4 => 11 } ); 11 __XML XML-Compile-1.64/t/70templ.t0000644000175000001440000001563214705454343016150 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 7; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema, 'load schema'); my $out = templ_perl($schema, "{$TestNS}test1", show => 'ALL', skip_header =>1); is($out, <<__TEST1a__, 'test 1a'); # Describing complex x0:test1 # {http://test-types}test1 # is an unnamed complex { # sequence of t1_a, t1_b, t1_c, t1_d, cho_t1_g # is a xs:int t1_a => 42, # is a xs:int t1_b => 42, # is a x0:test2 # occurs 1 <= # <= 2 times t1_c => [ { # is a xs:int # becomes an attribute a3_a => 42, # is a xs:int # becomes an attribute a2_a => 42, # is a xs:string # attribute a2_b is required a2_b => "example", # sequence of t3_a, t3_b # is a xs:anyType t3_a => "anything", # is a xs:int # value < 77 # value >= 12 t3_b => 42, # sequence of t2_a # is a xs:int t2_a => 42, }, ], # is an unnamed complex t1_d => { # sequence of t1_e, t1_f # is a xs:string t1_e => "example", # is a xs:float # occurs 1 <= # <= 2 times t1_f => [ 3.1415, ], }, # choice of t1_g, t1_h, t1_i # occurs 1 <= # <= 3 times cho_t1_g => [ { # is a x0:test3 t1_g => { # is a xs:int # becomes an attribute a3_a => 42, # sequence of t3_a, t3_b # is a xs:anyType t3_a => "anything", # is a xs:int # value < 77 # value >= 12 t3_b => 42, }, # is a xs:int # is optional t1_h => 42, # is a xs:negativeInteger # occurs 1 <= # <= unbounded times t1_i => [ -1, ], }, ], } __TEST1a__ $out = templ_perl($schema, "{$TestNS}test1", show => 'NONE', indent => ' ', skip_header => 1); is($out, <<__TEST1b__, 'test 1b'); # Describing complex x0:test1 # {http://test-types}test1 { t1_a => 42, t1_b => 42, t1_c => [ { a3_a => 42, a2_a => 42, a2_b => "example", t3_a => "anything", t3_b => 42, t2_a => 42, }, ], t1_d => { t1_e => "example", t1_f => [ 3.1415, ], }, cho_t1_g => [ { t1_g => { a3_a => 42, t3_a => "anything", t3_b => 42, }, t1_h => 42, t1_i => [ -1, ], }, ], } __TEST1b__ $out = templ_xml($schema, "{$TestNS}test1", show => 'ALL', skip_header => 1 , use_default_namespace => 1, include_namespaces => 1); is($out, <<__TEST1c__, 'test 1c'); 42 42 anything 42 42 example 3.1415 anything 42 42 -1 __TEST1c__ $out = templ_xml($schema, "{$TestNS}test1", show => 'NONE', skip_header => 1 , use_default_namespace => 1, include_namespaces => 1); is($out, <<__TEST1d__, 'test 1d'); 42 42 anything 42 42 example 3.1415 anything 42 42 -1 __TEST1d__ $out = templ_perl($schema, "{$TestNS}test3", show => 'ALL', skip_header => 1 , key_rewrite => 'PREFIXED', include_namespaces => 1 , prefixes => [ 'me' => $TestNS ], elements_qualified => 'ALL'); is($out, <<__TEST3__, 'test 3'); # Describing complex me:test3 # {http://test-types}test3 # xmlns:me http://test-types # is a me:test3 { # is a xs:int # becomes an attribute a3_a => 42, # sequence of me_t3_a, me_t3_b # is a xs:anyType me_t3_a => "anything", # is a xs:int # value < 77 # value >= 12 me_t3_b => 42, } __TEST3__ my $tree = templ_tree($schema, "{$TestNS}test3"); #use Data::Dumper; #$Data::Dumper::Indent = 1; #$Data::Dumper::Quotekeys = 0; #warn Dumper $tree; isa_ok($tree, 'HASH'); XML-Compile-1.64/t/77form.t0000644000175000001440000000324114703742164015771 0ustar00markovusers00000000000000#!/usr/bin/env perl # test "form" overrule. The code is derived from bugreport #86079 # by Manfred Stock. use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use XML::Compile::Util qw/pack_type SCHEMA2001/; use Test::More tests => 36; my $schemans = SCHEMA2001; my $tns = 'http://test-types'; my $template = <<__SCHEMA; __SCHEMA my @combinations = ( [ 'qualified', 'qualified', <<__QQ ] 42 3 __QQ , [ 'unqualified', 'qualified', <<__UQ ] 42 3 __UQ , [ 'qualified', 'unqualified', <<__QU ] 42 3 __QU , [ 'unqualified', 'unqualified', <<__UU ] 42 3 __UU ); set_compile_defaults include_namespaces => 1 , use_default_namespace => 0; foreach (@combinations) { my ($schema_form, $elem_form, $expect) = @$_; my $data = $template; $data =~ s{__FORM01__}{$schema_form}; $data =~ s{__FORM02__}{$elem_form}; ok 1, "next combination: elementFormDefault=$schema_form, form=$elem_form"; my $schema = XML::Compile::Schema->new($data); test_rw $schema, request => $expect, {x => 42, y => 3}; } XML-Compile-1.64/t/91noqual.t0000644000175000001440000000370414703742164016325 0ustar00markovusers00000000000000#!/usr/bin/env perl # Test schemas unqualified schemas with target-namespace use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 27; set_compile_defaults include_namespaces => 1 , prefixes => [ me => $TestNS ]; # targetNamespace and elementFormDefault just to add confusion. my $s = <<__SCHEMA; __SCHEMA my $schema = XML::Compile::Schema->new($s , target_namespace => $TestNS , element_form_default => 'qualified' ); # $schema->printIndex; ok(defined $schema, 'compiled schema'); is(join("\n", join "\n", $schema->types)."\n", "{$TestNS}ct1\n"); is(join("\n", join "\n", $schema->elements)."\n", <<__ELEMS__); {$TestNS}test1 {$TestNS}test2 {$TestNS}test4 __ELEMS__ test_rw($schema, test1 => <<__XML, 10); 10 __XML test_rw($schema, test2 => <<__XML, {c1_a => 11}); 11 __XML my %t4 = (c1_a => 14, a1_a => 15, c4_a => 16, a4_a => 17); test_rw($schema, test4 => <<__XML, \%t4); 14 16 __XML XML-Compile-1.64/t/TestTools.pm0000644000175000001440000000510214705455267016766 0ustar00markovusers00000000000000# Copyrights 2006-2024 by [Mark Overmeer ]. # For other contributors see ChangeLog. # See the manual pages for details on the licensing terms. # Pod stripped from pm file by OODoc 2.03. use warnings; use strict; package TestTools;{ our $VERSION = '1.64'; } use base 'Exporter'; use XML::LibXML; use XML::Compile::Util ':constants'; use XML::Compile::Tester; use Test::More; use Test::Deep qw/cmp_deeply eq_deeply/; use Log::Report; use Data::Dumper qw/Dumper/; our @EXPORT = qw/ $TestNS $SchemaNS $SchemaNSi $dump_pkg test_rw error_r error_w /; sub duplicate($); our $TestNS = 'http://test-types'; our $SchemaNS = SCHEMA2001; our $SchemaNSi = SCHEMA2001i; our $dump_pkg = 't::dump'; sub test_rw($$$$;$$) { my ($schema, $test, $xml, $hash, $expect, $h2) = @_; my $type = $test =~ m/\{/ ? $test : "{$TestNS}$test"; # reader my $r = reader_create $schema, $test, $type; defined $r or return; my $h = $r->($xml); #warn "READ OUTPUT: ",Dumper $h; unless(defined $h) # avoid crash of is_deeply { if(defined $expect && length($expect)) { ok(0, "failure: nothing read from XML"); } else { ok(1, "empty result"); } return; } #warn "COMPARE READ: ", Dumper($h, $hash); is_deeply($h, $hash, "from xml"); # Writer my $writer = writer_create $schema, $test, $type; defined $writer or return; my $msg = defined $h2 ? $h2 : $h; my $dupl; { no strict; $dupl = eval Dumper $msg } my $tree = writer_test $writer, $dupl; my $untouched = eq_deeply $msg, $dupl; ok($untouched, 'not tempered with written structure'); $untouched or warn Dumper $msg, $dupl; compare_xml($tree, $expect || $xml); } # Duplicate a complex data-structure, be sure libxml object will get # created again. sub duplicate($) { my $e = shift; !ref $e ? $e : ref $e eq 'ARRAY' ? [ map duplicate($_), @$e ] : ref $e eq 'HASH' ? { map +($_ => duplicate($e->{$_})), keys %$e } : $e->isa('XML::LibXML::Node') ? $e->cloneNode(1) : $e; # may break with some XS objects } sub error_r($$$) { my ($schema, $test, $xml) = @_; my $type = $test =~ m/\{/ ? $test : "{$TestNS}$test"; reader_error($schema, $type, $xml); } sub error_w($$$) { my ($schema, $test, $data) = @_; my $type = $test =~ m/\{/ ? $test : "{$TestNS}$test"; # the default dispatcher (::Perl) shows some non-fatal warnings dispatcher disable => 'default'; my $err = writer_error($schema, $type, $data); dispatcher enable => 'default'; $err; } 1; XML-Compile-1.64/t/76blocked.t0000644000175000001440000001112614703742164016431 0ustar00markovusers00000000000000#!/usr/bin/env perl # test blocking of namespaces use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; #use Log::Report mode => 'DEBUG'; use Test::More tests => 129; my $OtherNS = "http://test2/ns"; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); set_compile_defaults elements_qualified => 'NONE' , block_namespace => $OtherNS; # # simple or complex element # my $error = error_r($schema, test1 => '11'); is($error, "use of `other:t1' blocked at {$TestNS}test1"); $error = error_w($schema, test1 => 11); is($error, "use of `other:t1' blocked at {$TestNS}test1"); # should still work test_rw($schema, test2 => '12', 12); # # simpleType # $error = error_r($schema, test3 => XML::LibXML::Attr->new('test3', 13)); is($error, "use of simpleType `other:t3' blocked at {$TestNS}test3/\@test3"); $error = error_w($schema, test3 => 13); is($error, "use of simpleType `other:t3' blocked at {$TestNS}test3/\@test3"); test_rw($schema, test4 => XML::LibXML::Attr->new(test4 => '14') , 14, ' test4="14"'); $error = error_r($schema, test5 => '15'); is($error, "use of simpleType `other:t5' blocked at {$TestNS}test5#sres"); $error = error_w($schema, test5 => 15); is($error, "use of simpleType `other:t5' blocked at {$TestNS}test5#sres"); # # complexType choice # $error = error_r($schema, test6 => '16'); is($error, "use of `other:t6' blocked at {$TestNS}test6/a"); $error = error_w($schema, test6 => { a => 16 }); is($error, "use of `other:t6' blocked at {$TestNS}test6/a"); test_rw($schema, test6 => '16', {b => 16}); # # complexType extension/restriction # test_rw($schema, test7 => '17', {c => 17}); test_rw($schema, test8 => '18', {d => 18}); # # ref element in choice # $error = error_r($schema, test9 => '90'); is($error, "no applicable choice for `t9' at {$TestNS}test9"); $error = error_w($schema, test9 => { t9 => 90 }); is($error, "no match for required block `cho_test1' at {$TestNS}test9"); $error = error_r($schema, test9 => '91'); is($error, "use of `other:t1' blocked at {$TestNS}test9/me:test1"); $error = error_w($schema, test9 => { test1 => 91 }); is($error, "use of `other:t1' blocked at {$TestNS}test9/me:test1"); test_rw($schema, test9 => '92', {test2 => 92}); # # ref element in sequence # $error = error_r($schema, test10 => '100'); is($error, "element `t10' not processed for {$TestNS}test10 at /test10/t10"); $error = error_w($schema, test10 => { t10 => 100 }); is($error, "tag `t10' not used at {$TestNS}test10"); $error = error_r($schema, test10 => '101'); is($error, "use of `other:t1' blocked at {$TestNS}test10/me:test1"); $error = error_w($schema, test10 => { test1 => 101 }); is($error, "use of `other:t1' blocked at {$TestNS}test10/me:test1"); test_rw($schema, test10 => '102', {test2 => 102}); XML-Compile-1.64/t/51any.t0000644000175000001440000001634714703742164015620 0ustar00markovusers00000000000000#!/usr/bin/env perl # test any and anyAttribute # any with list of url's is not yet tested. use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 82; my $NS2 = "http://test2/ns"; my $doc = XML::LibXML::Document->new('test doc', 'utf-8'); isa_ok($doc, 'XML::LibXML::Document'); my $root = $doc->createElement('root'); $doc->setDocumentElement($root); $root->setNamespace('http://x', 'b', 1); my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $error; set_compile_defaults include_namespaces => 1; my %t2a = (tns_e => 10, tns_a => 11); test_rw($schema, test2 => <<__XML, \%t2a); 10 __XML # # Take it, in target namespace # set_compile_defaults include_namespaces => 1 , any_element => 'TAKE_ALL' , any_attribute => 'TAKE_ALL'; my $r2b = reader_create($schema, test2 => "{$TestNS}test2"); my $h2b = $r2b->( <<__XML); 9 10 __XML is(delete $h2b->{tns_e}, 9); is(delete $h2b->{tns_a}, 11); my $x2ba = delete $h2b->{"{$TestNS}tns_a"}; my $x2be = delete $h2b->{"{$TestNS}tns_e"}; ok(!keys %$h2b); ok(defined $x2ba); ok(defined $x2be); isa_ok($x2ba, 'XML::LibXML::Attr'); isa_ok($x2be, 'ARRAY'); cmp_ok(scalar(@$x2be), '==', 1); isa_ok($x2be->[0], 'XML::LibXML::Element'); is($x2ba->toString, ' tns_a="11"'); is($x2be->[0]->toString, '10'); # writer my $nat_at_type = "{$TestNS}nat_at"; my $nat_at = $doc->createAttributeNS($TestNS, 'nat_at', 24); ok(defined $nat_at, "create native attribute nat_at"); my $for_at_type = '{http://x}for_at'; my $for_at = $doc->createAttributeNS('http://x', 'for_at', 23); ok(defined $for_at, "create foreign attribute for_at"); isa_ok($for_at, 'XML::LibXML::Attr'); my $nat_el_type = "{$TestNS}nat_el"; my $nat_el = $doc->createElementNS($TestNS, 'nat_el'); ok(defined $nat_el, "create native element nat_el"); $nat_el->appendText(25); is($nat_el->toString, '25'); my $for_el_type = '{http://x}for_el'; my $for_el = $doc->createElementNS('http://x', 'for_el'); ok(defined $for_el, "create foreign element for_el"); isa_ok($for_el, 'XML::LibXML::Element'); $for_el->appendText(26); is($for_el->toString, '26'); my %h2c = (tns_a => 21, tns_e => 22 , $nat_at_type => $nat_at, $for_at_type => $for_at , $nat_el_type => $nat_el, $for_el_type => $for_el ); $error = error_w($schema, test2 => \%h2c); is($error, "unused tags {http://x}for_at {http://x}for_el at {http://test-types}test2"); # # Take only other namespace # my $r3b = reader_create($schema, test3 => "{$TestNS}test3"); my $h3b = $r3b->( <<__XML); 10 26 __XML is(delete $h3b->{other_e}, 10); is(delete $h3b->{other_a}, 11); my $x3b = delete $h3b->{"{http://x}other_b"}; ok(defined $x3b); isa_ok($x3b, 'XML::LibXML::Attr'); is($x3b->toString, ' b:other_b="12"'); my $x3b2 = delete $h3b->{"{http://x}for_el"}; ok(defined $x3b2); isa_ok($x3b2, 'ARRAY'); cmp_ok(scalar(@$x3b2), '==', 1); isa_ok($x3b2->[0], 'XML::LibXML::Element'); is($x3b2->[0]->toString, '26'); ok(!keys %$h3b); # writer error my %h3c = (other_a => 10, other_e => 11 , $nat_at_type => $nat_at, $for_at_type => $for_at , $nat_el_type => $nat_el, $for_el_type => $for_el ); $error = error_w($schema, test3 => \%h3c); is($error, "unused tags {http://test-types}nat_at {http://test-types}nat_el at {http://test-types}test3"); # # Take any namespace # my $r4b = reader_create($schema, test4 => "{$TestNS}test4"); my $h4b = $r4b->( <<__XML); 10 __XML is(delete $h4b->{any_e}, 10); is(delete $h4b->{any_a}, 11); my $x4b = delete $h4b->{"{$TestNS}any_a"}; ok(defined $x4b); isa_ok($x4b, 'XML::LibXML::Attr'); is($x4b->toString, ' any_a="11"'); my $x4b2 = delete $h4b->{"{http://x}any_b"}; ok(defined $x4b2); isa_ok($x4b2, 'XML::LibXML::Attr'); is($x4b2->toString, ' b:any_b="12"'); ok(!keys %$h4b); # writer my %h4c = ( any_a => 10, any_e => 11 , $nat_at_type => $nat_at , $for_at_type => $for_at); my $w4c = writer_create($schema, test4 => "{$TestNS}test4"); my $h4c = writer_test($w4c, \%h4c); compare_xml($h4c, <<__XML); 11 __XML set_compile_defaults include_namespaces => 1 , prefixes => [ '' => $TestNS, b => 'http://x' ] ; my %h4d = ( any_a => 10, any_e => 11 , ':nat_at' => $nat_at , 'b:for_at' => $for_at ); my $w4d = writer_create($schema, test4 => "{$TestNS}test4"); my $h4d = writer_test($w4d, \%h4d); compare_xml($h4d, <<__XML); 11 __XML # # Test filter # my @filtered; sub filter_any($$) { my ($type, $value) = @_; push @filtered, $type; ok(defined $type, "filter $type"); isa_ok($value, 'XML::LibXML::Attr'); my $flat = $value->toString; $type =~ m/_a/ ? ($type, $flat) : (); }; set_compile_defaults include_namespaces => 1 , any_element => 'TAKE_ALL' , any_attribute => \&filter_any; my $r5b = reader_create($schema, test4 => "{$TestNS}test4"); my $h5b = $r5b->( <<__XML); 10 __XML is(delete $h5b->{any_e}, 10); is(delete $h5b->{any_a}, 11); my $x5b = delete $h5b->{"{$TestNS}any_a"}; is($x5b, ' any_a="11"'); my $x5b2 = delete $h5b->{"{http://x}any_b"}; ok(!defined $x5b2); ok(!keys %$h5b); XML-Compile-1.64/t/61hooks_w.t0000644000175000001440000000466014703742164016476 0ustar00markovusers00000000000000#!/usr/bin/env perl # hooks in ::Translate::Writer use warnings; use strict; use lib 'lib','t'; use TestTools; use Data::Dumper; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 31; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $xml1 = <<__XML; aap 2 3 __XML # test without hooks my %f1 = (byType => 'aap', byId => 2, byPath => 3); test_rw($schema, test1 => $xml1, \%f1); # try all selectors and hook types my (@out, @out2); my $w2 = writer_create ( $schema, "combined test" => "{$TestNS}test1" , hook => { type => 'string' , id => 'my_id' , path => qr/byPath/ , before => sub { push @out, $_[2]; $_[1] } , after => sub { push @out2, $_[2]; $_[1] } } ); ok(defined $w2); my $h2 = writer_test($w2, \%f1); ok(defined $h2); cmp_ok(scalar @out, '==', 3, '3 objects logged before'); cmp_ok(scalar @out2, '==', 3, '3 objects logged after'); compare_xml($h2, <<__EXPECT); aap 2 3 __EXPECT # test predefined and multiple "after"s my $output; open BUF, '>', \$output; my $oldout = select BUF; my $w3 = writer_create ( $schema, "multiple after" => "{$TestNS}test1" , hook => { id => 'top' , after => [ 'PRINT_PATH' ] } ); my $h3 = writer_test($w3, \%f1); ok(defined $h3, 'multiple after predefined'); select $oldout; close BUF; like($output, qr/\}test1\n$/, 'PRINT_PATH'); compare_xml($h3, <<__EXPECT); aap 2 3 __EXPECT # test skip my $w4 = writer_create ( $schema, "test SKIP" => "{$TestNS}test1" , hook => { id => 'my_id' , replace => 'SKIP' } ); my $h4 = writer_test($w4, \%f1); ok(defined $h4, 'test skip'); compare_xml($h4, <<__EXPECT); aap 3 __EXPECT XML-Compile-1.64/t/20spec.t0000644000175000001440000000353414703742164015751 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use File::Spec; use lib 'lib', 't'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 22; our $xmlfile = XML::Compile->findSchemaFile('2001-XMLSchema.xsd'); ok(-r $xmlfile, 'find demo file'); my $parser = XML::LibXML->new; my $doc = $parser->parse_file($xmlfile); ok(defined $doc, 'parsing schema'); isa_ok($doc, 'XML::LibXML::Document'); my $defs = XML::Compile::Schema->new($doc); ok(defined $defs); my $namespaces = $defs->namespaces; isa_ok($namespaces, 'XML::Compile::Schema::NameSpaces'); my @ns = $namespaces->list; cmp_ok(scalar(@ns), '==', 1, 'one target namespace'); my $ns = shift @ns; is($ns, $SchemaNS); my @schemas = $namespaces->namespace($ns); ok(scalar(@schemas), 'found ns'); @schemas or die "no schemas, so no use to continue"; cmp_ok(scalar(@schemas), '==', 1, "one schema"); my $schema = $schemas[0]; my $list = ''; open OUT, '>', \$list or die $!; $_->printIndex(\*OUT) for @schemas; close OUT; #warn $list; my @types = split /\n/, $list; is(shift(@types), "namespace: $SchemaNS"); is(shift(@types), " source: XML::LibXML::Document"); cmp_ok(scalar(@types), '==', 150); my $random = (sort @types)[42]; is($random, ' derivationControl'); cmp_ok(scalar($schema->simpleTypes), '==', 55); cmp_ok(scalar($schema->complexTypes), '==', 35); cmp_ok(scalar($schema->groups), '==', 12); cmp_ok(scalar($schema->attributeGroups), '==', 2); cmp_ok(scalar($schema->elements), '==', 41); cmp_ok(scalar($schema->attributes), '==', 0); #cmp_ok(scalar($schema->notations), '==', 2); my $testtype = '{http://www.w3.org/2001/XMLSchema}derivationControl'; my $lookup = $schema->find(simpleType => $testtype); ok(defined $lookup, 'found simpleType'); is(ref $lookup, 'HASH'); ok(!$schema->find(complexType => $testtype)); XML-Compile-1.64/t/03duration.t0000644000175000001440000000372214703742164016644 0ustar00markovusers00000000000000#!/usr/bin/env perl # Check implementation of type extension administration use warnings; use strict; use File::Spec; use POSIX qw/strftime tzset/; use lib 'lib', 't'; use XML::Compile::Util qw/duration2secs add_duration/; use Test::More; # On some platforms (Windows), tzset is not supported so we cannot produce # consistent time output. eval { tzset }; plan skip_all => $@ if $@; plan tests => 16; # examples taken from http://www.schemacentral.com/sc/xsd/t-xsd_duration.html ### test duration2secs # 2 yrs, 6 months, 5 days, 12 hours, 35 minutes, 30 seconds cmp_ok(duration2secs('P2Y6M5DT12H35M30S'), '==', 79352926.8); cmp_ok(duration2secs('P1DT2H'), '==', 93600); # 1 day, 2 hours # 20 months (the number of months can be more than 12) cmp_ok(duration2secs('P20M'), '==', 52531200); cmp_ok(duration2secs('PT20M'), '==', 1200); # 20 minutes # 20 months (0 is permitted as a number, but is not required) cmp_ok(duration2secs('P0Y20M0D'), '==', 52531200); cmp_ok(duration2secs('P0Y'), '==', 0); # 0 years cmp_ok(duration2secs('-P60D'), '==', -5184000); # minus 60 days cmp_ok(duration2secs('PT1M30.5S'), '==', 90.5); # 1 minute, 30.5 seconds ### test add_duration $ENV{TZ} = 'UCT'; tzset; sub t($) {strftime "%Y-%m-%dT%H:%M:%S", gmtime shift} # used to calculate some fixed reference point in time # my $now = time; my $now = 1397731609; # 2014-04-17T10:46:49Z #print "$now=",t($now), "\n"; cmp_ok(t(add_duration('P2Y6M5DT12H35M30S', $now)), 'eq', '2016-10-22T23:22:19'); cmp_ok(t(add_duration('P1DT2H', $now)), 'eq', '2014-04-18T12:46:49'); cmp_ok(t(add_duration('P20M', $now)), 'eq', '2015-12-17T10:46:49'); cmp_ok(t(add_duration('PT20M', $now)), 'eq', '2014-04-17T11:06:49'); cmp_ok(t(add_duration('P0Y20M0D', $now)), 'eq', '2015-12-17T10:46:49'); cmp_ok(t(add_duration('P0Y', $now)), 'eq', '2014-04-17T10:46:49'); cmp_ok(t(add_duration('-P60D', $now)), 'eq', '2014-02-16T10:46:49'); cmp_ok(t(add_duration('PT1M30.5S', $now)), 'eq', '2014-04-17T10:48:19'); XML-Compile-1.64/t/63mixed.t0000644000175000001440000000707514703742164016140 0ustar00markovusers00000000000000#!/usr/bin/env perl # Mixed elements use warnings; use strict; use lib 'lib','t'; use TestTools; use Data::Dumper; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 39; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $mixed1 = <<'__XML'; aaa 13 bbb __XML #### the default = ATTRIBUTES my $r1 = reader_create $schema, "nameless with attrs" => "{$TestNS}test1"; my $r1a = $r1->($mixed1); isa_ok($r1a, 'HASH', 'got result'); is($r1a->{id}, '5', 'check attribute'); ok(exists $r1a->{_}, 'has node'); isa_ok($r1a->{_}, 'XML::LibXML::Element'); compare_xml($r1a->{_}->toString, $mixed1); # test generic writer my $w1 = writer_create $schema, "nameless with attrs" => "{$TestNS}test1"; my $w1node = XML::LibXML::Element->new('test1'); my $w1a = writer_test($w1, $w1node); compare_xml($w1a, ''); my $w1b = writer_test($w1, { _ => $w1node, id => 6}); compare_xml($w1b, ''); # test template my $out = templ_perl $schema, "{$TestNS}test1", skip_header => 1; is($out, <<'__TEMPL'); # Describing mixed x0:test1 # {http://test-types}test1 # is an unnamed complex # test1 has a mixed content { # is a xs:string # becomes an attribute id => "example", # mixed content cannot be processed automatically _ => XML::LibXML::Element->new('test1'), } __TEMPL #### explicit ATTRIBUTES set_compile_defaults elements_qualified => 'NONE' , mixed_elements => 'ATTRIBUTES'; my $r2 = reader_create $schema, attributes => "{$TestNS}test1"; my $r2a = $r2->($mixed1); isa_ok($r2a, 'HASH', 'got result'); is($r2a->{id}, '5', 'check attribute'); ok(exists $r2a->{_}, 'has node'); isa_ok($r2a->{_}, 'XML::LibXML::Element'); compare_xml($r2a->{_}->toString, $mixed1); #### CODE reference my @caught; set_compile_defaults elements_qualified => 'NONE' , mixed_elements => sub {@caught = @_; '42' }; my $r3 = reader_create($schema, "code reference" => "{$TestNS}test1"); my $r3a = $r3->($mixed1); is($r3a, 42); cmp_ok(scalar @caught, '==', 2); # got $path and $node isa_ok($caught[1], 'XML::LibXML::Element'); #### XML_NODE set_compile_defaults elements_qualified => 'NONE' , mixed_elements => 'XML_NODE'; my $r4 = reader_create($schema, "xml-node" => "{$TestNS}test1"); my $r4a = $r4->($mixed1); isa_ok($r4a, 'XML::LibXML::Element'); #### TEXTUAL set_compile_defaults elements_qualified => 'NONE' , mixed_elements => 'TEXTUAL'; my $r5 = reader_create($schema, textual => "{$TestNS}test1"); my $r5a = $r5->($mixed1); isa_ok($r5a, 'HASH', 'got result'); is($r5a->{id}, '5', 'check attribute'); ok(exists $r5a->{_}, 'has text'); is($r5a->{_}, <<'__TEXT'); aaa 13 bbb __TEXT #### STRUCTURAL set_compile_defaults elements_qualified => 'NONE' , mixed_elements => 'STRUCTURAL'; my $r6 = reader_create($schema, structural => "{$TestNS}test1"); my $r6a = $r6->($mixed1); is_deeply($r6a, {count => 13, id => 5}); #### XML_STRING set_compile_defaults elements_qualified => 'NONE' , mixed_elements => 'XML_STRING'; my $r7 = reader_create($schema, "xml-string" => "{$TestNS}test1"); my $r7a = $r7->($mixed1); is(ref $r7a, '', 'returned is string'); $r7a =~ s/\n?$/\n/; is($r7a, $mixed1); XML-Compile-1.64/t/31elem.t0000644000175000001440000000432614703742164015743 0ustar00markovusers00000000000000#!/usr/bin/env perl # # Run some general tests around the generation of elements. We will # test seperate components in more detail in other scripts. use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 65; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); # # simple element type # test_rw($schema, test1 => <<__XML, 42); 42 __XML test_rw($schema, test1 => <<__XML, -1); -1 __XML test_rw($schema, test1 => <<__XML, 121); 121 __XML # # the simpleType, less simple type # test_rw($schema, test3 => <<__XML, 78); 78 __XML test_rw($schema, test6 => <<__XML, 79); 79 __XML # # The not so complex complexType # test_rw($schema, test4 => <<__XML, {ct_1 => 14, ct_2 => 43}); 14 43 __XML test_rw($schema, test5 => <<__XML, {ct_1 => 15, ct_2 => 44}); 15 44 __XML # for test6 see above # # Test default: should not be set automatically # test_rw($schema, test7 => <<__XML, {ct_1 => 41, ct_2 => 42}, <<__XML, {ct_1 => 41}); 41 __XML 41 __XML XML-Compile-1.64/t/72typemap.t0000644000175000001440000001303114703742164016476 0ustar00markovusers00000000000000#!/usr/bin/env perl # convert XML into objects and back use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use XML::Compile::Util qw/pack_type/; use Data::Dumper; use Test::More tests => 65; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ my $doc = XML::LibXML::Document->new('1.0', 'UTF-8'); ok(defined $doc, 'created document'); # # Simple checks for "after" hook in reader, and "before" hook in writer # we will use hooks, so be sure it works correctly. # my @out; my $t1 = "{$TestNS}test1"; $schema->addHook(type => $t1, after => sub {@out = @_; $_[1]}); # reader my $r1 = create_reader $schema, 'after hook' => $t1; isa_ok($r1, 'CODE', 'after read'); my $h1 = $r1->('one'); is($h1, 'one', 'reader works'); cmp_ok(scalar @out, '==', 4, 'hook called with 4 params'); isa_ok($out[0], 'XML::LibXML::Node', 'got node'); is($out[1], 'one', 'parsed data'); # writer @out = (); my $w1 = create_writer $schema, 'after hook' => $t1; isa_ok($w1, 'CODE', 'after read'); my $w1h = $w1->($doc, 'two'); isa_ok($w1h, 'XML::LibXML::Element', 'writer works'); cmp_ok(scalar @out, '==', 5, 'hook called with 5 params'); is($out[0], $doc, 'document'); isa_ok($out[1], 'XML::LibXML::Element', 'generated node'); is($out[2], $t1, 'type'); is($out[3], 'two', 'data'); ### ##### now the real thing ### # # test typemap reader with code # my $type2 = pack_type $TestNS, 'test2'; @out = (); my $r2 = create_reader $schema, "typemap code" => $type2 , typemap => {$type2 => sub {@out = @_; $_[1]}}; ok(defined $r2, 'typemap reader from code'); my $h2 = $r2->('bbb'); cmp_ok(scalar(@out), '==', 3, 'reader with CODE'); is($out[0], 'READER'); is_deeply($out[1], {e2 => 'bbb'}); is($out[2], $type2); isa_ok($h2, 'HASH'); is_deeply($h2, {e2 => 'bbb'}); # A class where we can modify the fromXML and toXML methods. my ($from_xml, $to_xml); package My::Class; sub fromXML(@) { $from_xml->(@_) } sub toXML(@) { $to_xml->(@_) } package main; # # test fromXML with Class name # $from_xml = sub { my ($class, $data, $type) = @_; ok(1, 'fromXML called'); is($class, 'My::Class'); is($type, $type2); isa_ok($data, 'HASH'); ok(exists $data->{e2}); bless $data, 'My::Class'; }; my $r3 = create_reader $schema, "typemap class" => $type2 , typemap => {$type2 => 'My::Class'}; ok(defined $r3, 'typemap reader from class'); my $h3 = $r3->('aaa'); is_deeply($h3, bless {e2 => 'aaa'}, 'My::Class'); # # test fromXML with Object # my $interface = bless {}, 'My::Class'; $from_xml = sub { my ($self, $data, $type) = @_; ok(1, 'fromXML called'); isa_ok($self, 'My::Class'); is_deeply($data, {e2 => 'ccc'}); {e3 => 'donkey'}; }; my $r4 = create_reader $schema, "typemap object" => $type2 , typemap => {$type2 => $interface}; ok(defined $r4, 'typemap reader from object'); my $h4 = $r4->('ccc'); is_deeply($h4, {e3 => 'donkey'}); # # test toXML with CODE # @out = (); my $someobj = bless {e2 => 'bbb'}, 'My::Class'; my $w2 = create_writer $schema, "toXML CODE" => $type2 , typemap => {$type2 => sub {@out = @_; $_[1]}}; ok(defined $w2, 'typemap writer from code'); my $x2 = $w2->($doc, $someobj); cmp_ok(scalar(@out), '==', 4, 'writer with CODE'); is($out[0], 'WRITER'); is_deeply($out[1], $someobj); is($out[2], $type2); isa_ok($out[3], 'XML::LibXML::Document'); compare_xml($x2, 'bbb'); my $out = templ_perl $schema, "{$TestNS}test2", skip_header => 1 , typemap => { $type2 => '&function'}; is($out, <<__TEMPL); # call on converter function with object \$function->('WRITER', \$object, '{$TestNS}test2', \$doc) __TEMPL # # test toXML with Class # $to_xml = sub { my ($self, $type, $d) = @_; ok(1, 'toXML called'); is_deeply($self, $someobj); isa_ok($self, 'My::Class'); is($type, $type2); isa_ok($d, 'XML::LibXML::Document'); $self; }; my $w3 = create_writer $schema, "toXML Class" => $type2 , typemap => {$type2 => 'My::Class'}; ok(defined $w3, 'typemap writer from class'); my $x3 = $w3->($doc, $someobj); compare_xml($x3, 'bbb'); $out = templ_perl $schema, "{$TestNS}test2", skip_header => 1 , typemap => { $type2 => 'My::Class'}; is($out, <<__TEMPL); # calls toXML() on My::Class objects # with {http://test-types}test2 and doc bless({}, 'My::Class') __TEMPL # # test toXML with Object # $to_xml = sub { my ($self, $obj, $type, $d) = @_; ok(1, 'toXML called'); isa_ok($self, 'My::Class'); isa_ok($obj, 'My::Class'); # usually some other type is_deeply($obj, $someobj); is($type, $type2); isa_ok($d, 'XML::LibXML::Document'); $obj; }; my $w4 = create_writer $schema, "toXML object" => $type2 , typemap => {$type2 => $interface}; ok(defined $w4, 'typemap writer from object'); my $x4 = $w4->($doc, $someobj); compare_xml($x4, 'bbb'); $out = templ_perl $schema, "{$TestNS}test2", skip_header => 1 , typemap => { $type2 => '$interface'}; is($out, <<__TEMPL); # call on converter with object \$interface->toXML(\$object, '{$TestNS}test2', \$doc) __TEMPL XML-Compile-1.64/t/45ctcext.t0000644000175000001440000000615414703742164016321 0ustar00markovusers00000000000000#!/usr/bin/env perl # test complex type extensions use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 50; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my %t1 = (t1_a => 11, t1_b => 12, a1_a => 13, a1_b => 14, t2_a => 15, a2_a=>16); test_rw($schema, "test1" => <<__XML, \%t1); 11 12 15 __XML ### no base block test_rw($schema, test3 => <<__XML, {a3_a => 20}); __XML test_rw($schema, test4 => <<__XML, {a3_a => 21, a4_a => 22, e4_a => 23}); 23 __XML ### nested repeats my %t6 = ( e6 => [ { e5 => [ 30, 31 ] } , { e5 => [ 32 ] } , { } ] ); test_rw($schema, test6 => <<__XML, \%t6); 3031 32 __XML test_rw($schema, test6 => '', {}); test_rw($schema, test6 => '', {e6 => [ {} ]} ); # attempt to reproduce bug rt.cpan.org#79986, reported by Karen Etheridge my $out = templ_perl $schema, "{$TestNS}test1", skip_header => 1; is($out, <<__EXPECT, 'templ of extension'); # Describing complex x0:test1 # {http://test-types}test1 # is a x0:t2 { # is a xs:int # becomes an attribute a1_a => 42, # is a xs:int # attribute a1_b is required a1_b => 42, # is a xs:int # becomes an attribute a2_a => 42, # sequence of t1_a, t1_b # is a xs:int t1_a => 42, # is a xs:int t1_b => 42, # sequence of t2_a # is a xs:int t2_a => 42, } __EXPECT XML-Compile-1.64/t/81-2000.t0000644000175000001440000000110514703742164015454 0ustar00markovusers00000000000000#!/usr/bin/env perl # check access to old schema types use warnings; use strict; use File::Spec; use lib 'lib', 't'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 9; set_compile_defaults elements_qualified => 'NONE'; my $oldns = 'http://www.w3.org/2000/10/XMLSchema'; my $schema = XML::Compile::Schema->new( <<__SCHEMA ); __SCHEMA ok(defined $schema); test_rw($schema, test1 => '42', 42); XML-Compile-1.64/t/55facet_dura.t0000644000175000001440000000232614703742164017122 0ustar00markovusers00000000000000#!/usr/bin/env perl # test facets on duration, shares some with numeric facets use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use XML::Compile::Util qw/pack_type/; use Test::More tests => 21; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ );   __SCHEMA__ ok(defined $schema); set_compile_defaults include_namespaces => 0 , elements_qualified => 'NONE' , use_default_namespace => 0; # a bit more test_rw($schema, test1 => 'P1970Y02M01D' , 'P1970Y02M01D'); # a bit less my $error = error_r($schema, test1 => 'P1970Y'); is($error, "too small minInclusive duration P1970Y, min P1970Y01M01D at {http://test-types}test1#facet"); # exact test_rw($schema, test1 => 'P1970Y01M01D' , 'P1970Y01M01D'); XML-Compile-1.64/t/55facet_list.t0000644000175000001440000000511414705455267017147 0ustar00markovusers00000000000000#!/usr/bin/env perl # test facets on list elements use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More; use XML::LibXML; BEGIN { # old libxml2 versions break on regex 123\\s+(\\d+\\s)*456 # there are so many bugs in old libxml2 releases! my $xml2_version = XML::LibXML::LIBXML_VERSION(); $xml2_version lt '20700' and plan skip_all => "Your libxml2 is too old (version $xml2_version)"; plan tests => 60; } set_compile_defaults elements_qualified => 'NONE' , sloppy_integers => 1; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); ### test length my $error = error_r($schema, test1 => <<_XML); 9 10 11 _XML is($error, "list `9 10 11' does not have required length 2 at {http://test-types}test1#facet"); $error = error_r($schema, test1 => <<_XML); 12 _XML is($error, "list `12' does not have required length 2 at {http://test-types}test1#facet"); $error = error_w($schema, test1 => [13]); is($error, "list `13' does not have required length 2 at {http://test-types}test1#facet"); $error = error_w($schema, test1 => [14, 15, 16]); is($error, "list `14 15 16' does not have required length 2 at {http://test-types}test1#facet"); test_rw($schema, test1 => <<_XML, [17, 18]); 17 18 _XML ### test patterns test_rw($schema, test2 => <<_XML, [123, 456]); 123 456 _XML test_rw($schema, test2 => <<_XML, [123, 987, 456]); 123 987 456 _XML test_rw($schema, test2 => <<_XML, [123, 987, 567, 456]); 123 987 567 456 _XML $error = error_r($schema, test2 => <<_XML); 999 _XML is($error, "string `999' does not match pattern `123\\s+(\\d+\\s)*456' at {http://test-types}test2#facet"); $error = error_w($schema, test2 => [111, 999]); is($error, "string `111 999' does not match pattern `123\\s+(\\d+\\s)*456' at {http://test-types}test2#facet"); XML-Compile-1.64/t/60hooks_r.t0000644000175000001440000000741414703742164016470 0ustar00markovusers00000000000000#!/usr/bin/env perl # hooks in ::Translate::Reader use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 45; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $xml1 = <<__XML; aap 2 3 __XML # test without hooks my %f1 = (byType => 'aap', byId => 2, byPath => 3); test_rw($schema, test1 => $xml1, \%f1); # try all selectors and hook types my (@out, @out2); my $r2 = reader_create ( $schema, "combined hook" => "{$TestNS}test1" , hook => { type => 'string' , id => 'my_id' , path => qr/byPath/ , before => sub { push @out, $_[1]; $_[0] } , after => sub { push @out2, $_[2]; $_[1] } } ); my $h2 = $r2->($xml1); ok(defined $h2, 'returned hash'); isa_ok($h2, 'HASH'); cmp_ok(scalar @out, '==', 3, '3 objects logged before'); cmp_ok(scalar @out2, '==', 3, '3 objects logged after'); # test predefined and multiple "after"s my $output; open BUF, '>', \$output; my $oldout = select BUF; my $r3 = reader_create ( $schema, "after PATH and NODE" => "{$TestNS}test1" , hook => { id => 'my_id' , after => [ qw/PRINT_PATH XML_NODE/ ] } ); my $h3 = $r3->($xml1); ok(defined $h3, 'multiple after predefined'); select $oldout; close BUF; #use Data::Dumper; #warn Dumper $h3; like($output, qr[\}test1/byId\n$], 'PRINT_PATH'); is(ref($h3->{byId}), 'HASH', 'simpleType expanded'); ok(exists $h3->{byId}{_}); cmp_ok($h3->{byId}{_}, '==', 2); ok(exists $h3->{byId}{_XML_NODE}); my $node = $h3->{byId}{_XML_NODE}; isa_ok($node, 'XML::LibXML::Element'); compare_xml($node, '2'); # test skip my $r4 = reader_create ( $schema, "replace SKIP" => "{$TestNS}test1" , hook => { id => 'my_id' , replace => 'SKIP' } ); my $h4 = $r4->($xml1); ok(defined $h4, 'test skip'); cmp_ok(scalar keys %$h4, '==', 3); ok(defined $h4->{byType}); ok(defined $h4->{byPath}); is($h4->{byId}, 'SKIPPED'); # test node order discovery my $xml2 = <<__XML; __XML my $r5 = reader_create ( $schema, "read ORDER" => "{$TestNS}test2" , hook => { id => 'top2' , after => [ qw/ELEMENT_ORDER ATTRIBUTE_ORDER/ ] } ); my $h5 = $r5->($xml2); ok(defined $h5, "node order"); ok(exists $h5->{_ELEMENT_ORDER}); my $order = $h5->{_ELEMENT_ORDER}; is(ref $order, 'ARRAY'); cmp_ok(scalar @$order, '==', 0, "no elements"); ok(exists $h5->{_ATTRIBUTE_ORDER}); $order = $h5->{_ATTRIBUTE_ORDER}; is(ref $order, 'ARRAY'); is_deeply($order, [ qw/attr1 attr2/ ]); # test element order my $r6 = reader_create ( $schema, "element order" => "{$TestNS}test1" , hook => { id => 'top' , after => [ qw/ELEMENT_ORDER ATTRIBUTE_ORDER/ ] } ); my $h6 = $r6->($xml1); ok(defined $h6, "node order"); ok(exists $h6->{_ELEMENT_ORDER}); $order = $h6->{_ELEMENT_ORDER}; is(ref $order, 'ARRAY'); is_deeply($order, [ qw/byType byId byPath/ ]); ok(exists $h6->{_ATTRIBUTE_ORDER}); $order = $h6->{_ATTRIBUTE_ORDER}; is(ref $order, 'ARRAY'); cmp_ok(scalar @$order, '==', 0, "no attributes"); XML-Compile-1.64/t/02ext.t0000644000175000001440000000420214703742164015610 0ustar00markovusers00000000000000#!/usr/bin/env perl # Check implementation of type extension administration use warnings; use strict; use File::Spec; use lib 'lib', 't'; use Test::More tests => 20; use XML::Compile::Schema; use XML::Compile::Util qw/pack_type/; use TestTools; my $s = XML::Compile::Schema->new( <<_SCHEMA ); _SCHEMA sub does_extend($$) { my ($f, $g) = @_; $f = pack_type $SchemaNS, $f if $f !~ m/^\{/; $g = pack_type $SchemaNS, $g if $g !~ m/^\{/; ok($s->doesExtend($f, $g), "$_[0] <- $_[1]"); } sub does_not_extend($$) { my ($f, $g) = @_; $f = pack_type $SchemaNS, $f if $f !~ m/^\{/; $g = pack_type $SchemaNS, $g if $g !~ m/^\{/; ok(!$s->doesExtend($f, $g), "not $_[0] <- $_[1]"); } does_extend 'anyType', 'anyType'; does_extend 'anySimpleType', 'anyType'; does_not_extend 'anyType', 'anySimpleType'; does_extend 'unsignedByte', 'unsignedShort'; does_extend 'unsignedByte', 'unsignedInt'; does_extend 'unsignedByte', 'unsignedLong'; does_extend 'unsignedByte', 'nonNegativeInteger'; does_extend 'unsignedByte', 'integer'; does_extend 'unsignedByte', 'decimal'; does_extend 'unsignedByte', 'anyAtomicType'; does_extend 'unsignedByte', 'anySimpleType'; does_extend 'unsignedByte', 'anyType'; does_extend pack_type($TestNS,'t1'), pack_type($TestNS, 't1'); does_extend pack_type($TestNS,'t1'), 'int'; does_extend pack_type($TestNS,'t2'), 'int'; does_extend pack_type($TestNS,'t2'), pack_type($TestNS, 't1'); does_extend pack_type($TestNS,'t1'), 'anySimpleType'; does_extend pack_type($TestNS,'t2'), 'anySimpleType'; does_extend pack_type($TestNS,'t3'), pack_type($TestNS, 't2'); does_extend pack_type($TestNS,'t3'), pack_type($TestNS, 't1'); XML-Compile-1.64/t/40seq.t0000644000175000001440000002706114703742164015612 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 262; use Log::Report 'try'; use XML::Compile::Util qw/SCHEMA2001i/; my $xsi = SCHEMA2001i; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); # # sequence as direct type # ok(1, "** Testing sequence with 1 element"); test_rw($schema, test1 => <<__XML, {t1_a => 41}); 41 __XML test_rw($schema, test3 => <<__XML, {t3_a => 43}); 43 __XML ok(1, "** Testing sequence with 2 elements"); test_rw($schema, test5 => <<__XML, {t5_a => 47, t5_b => 48}); 4748 __XML test_rw($schema, test6 => <<__XML, {t6_a => 48, t6_b => 49}); 4849 __XML { set_compile_defaults check_occurs => 1 , elements_qualified => 'NONE'; my $error = error_r($schema, test6 => <<__XML); 50 __XML is($error, "data for element or block starting with `t6_a' missing at {http://test-types}test6"); } # The next is not correct, but when we do not check occurrences it is... { set_compile_defaults check_occurs => 0 , elements_qualified => 'NONE'; test_rw($schema, test7 => <<__XML, {t7_b => [16], t7_c => [17]}); 16 17 __XML } set_compile_defaults elements_qualified => 'NONE'; { my $error = error_r($schema, test7 => <<__XML); 16 17 __XML is($error, "data for element or block starting with `t7_c' missing at {http://test-types}test7"); } my %r7 = (t7_a => 20, t7_b => [21,22], t7_c => [23,24], t7_d => [25], t7_e => [26,27,28]); test_rw($schema, test7 => <<__XML, \%r7); 20 21 22 23 24 25 26 27 28 __XML my %r8a = qw/t8_a 30 t8_b 31 t8_c 32 t8_d 33 t8_e 34 t8_f 35/; test_rw($schema, test8 => <<__XML, \%r8a); 30 31 32 33 34 35 __XML my %r9a = qw/t9_a 30 t9_b 31 t9_c 32 t9_d 33 t9_e 34 t9_f 35/; test_rw($schema, test9 => <<__XML, \%r9a); 30 31 32 33 34 35 __XML ##### test 2 my %r2a = qw/t2_a 30 t2_b 31 t2_c 32 t2_d 33 t2_e 34 t2_f 35/; test_rw($schema, test2 => <<__XML, \%r2a); 30 31 32 33 34 35 __XML #### test 4 my %t4a = ( t4_a => 40 , seq_t4_b => [ {t4_b => 41, t4_c => [42]} ] , t4_d => 43 ); test_rw($schema, test4 => <<__XML, \%t4a); 40 41 42 43 __XML my %t4b = ( t4_a => 50 , seq_t4_b => [ {t4_b => 51, t4_c => [52, 53]} , {t4_b => 54} , {t4_b => 55, t4_c => [56]} ] , t4_d => 57 ); test_rw($schema, test4 => <<__XML, \%t4b); 50 51 52 53 54 55 56 57 __XML my %t4c = (t4_a => 60, t4_d => 61); test_rw($schema, test4 => <<__XML, \%t4c); 60 61 __XML ##### test 11 my %t11a = (t11_a => 20, seq_t11_b => [ {t11_b => 21, t11_c => 22 } ] ); test_rw($schema, test11 => <<__XML, \%t11a); 20 21 22 __XML my %t11b = (seq_t11_b => [ {t11_b => 30, t11_c => 31 } , {t11_b => 32, t11_c => 33 } , {t11_b => 34, t11_c => 35 } ] ); test_rw($schema, test11 => <<__XML, \%t11b); 30 31 32 33 34 35 __XML my %t11c = (seq_t11_b => [ { t11_c => 40 } , {t11_b => 41, t11_c => 42 } , { t11_c => 43 } , {t11_b => 44, t11_c => 45 } , { t11_c => 46 } ] ); test_rw($schema, test11 => <<__XML, \%t11c); 40 41 42 43 44 45 46 __XML ### test 12 test_rw($schema, test12 => <<__XML, {t12 => 50}); 50 __XML test_rw($schema, test12 => <<__XML, {}); __XML ### test 13 test_rw($schema, test13 => <<__XML, {}); __XML ### test 14 try { error_r($schema, test14 => '') }; my $e14 = $@->wasFatal; is("$e14", "error: complexType contains particles, simpleContent or complexContent, not `element' at {http://test-types}test14\n"); ### test 15 try { error_r($schema, test15 => '') }; my $e15 = $@->wasFatal; is("$e15", "error: complexContent needs extension or restriction, not `element' at {http://test-types}test15\n"); ### test 16 test_rw($schema, test16 => <<__XML, {t16b => 51}); 51 __XML ### test 17 test_rw($schema, test17 => <<__XML, {t17a => 52}); 52 __XML test_rw($schema, test17 => '', {}); ### test 18 test_rw($schema, test18 => <<__XML, {t18a => {t17a => 52}}); 52 __XML ### test 19 test_rw($schema, test19 => <<__XML, {test19a => {}} ); __XML test_rw($schema, test19 => <<__XML, {test19b => {}} ); __XML ### test 20 test_rw($schema, test20 => <<__XML, {a => 1, b => 2, c => 3} ); 123 __XML test_rw($schema, test20 => <<__XML, {a => 4} ); 4 __XML my $error = error_r($schema, test20 => "56"); is($error, "data for element or block starting with `c' missing at {http://test-types}test20"); $error = error_w($schema, test20 => {a => 7, b => 8}); is($error, "required value for element `c' missing at {http://test-types}test20"); ### test 21 test_rw($schema, test21a => '', {}); test_rw($schema, test21b => '', {}); test_rw($schema, test21c => '', {}); set_compile_defaults include_namespaces => 1 , elements_qualified => 'NONE'; test_rw($schema, test21c => <<__XML, {_ => 'NIL'}); __XML XML-Compile-1.64/t/52anytype.t0000644000175000001440000000237714703742164016521 0ustar00markovusers00000000000000#!/usr/bin/env perl # test anyType use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 15; my $NS2 = "http://test2/ns"; my $doc = XML::LibXML::Document->new('test doc', 'utf-8'); isa_ok($doc, 'XML::LibXML::Document'); my $root = $doc->createElement('root'); $doc->setDocumentElement($root); $root->setNamespace('http://x', 'b', 1); my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); set_compile_defaults include_namespaces => 1; test_rw($schema, test1 => <<__XML, 10); 10 __XML my $r1 = reader_create($schema, "struct", "{$TestNS}test1"); my $elem = qq{1112}; my $e1 = $r1->($elem); isa_ok($e1, 'XML::LibXML::Element'); is($e1->toString, $elem); # # Hook # set_compile_defaults include_namespaces => 1 , any_type => sub { $_[2]->($_[0], $_[1])+2 }; my $r2 = reader_create($schema, "struct", "{$TestNS}test1"); my $elem2 = qq{11}; is($r2->($elem2), 13); XML-Compile-1.64/t/44stres.t0000644000175000001440000000413414703742164016162 0ustar00markovusers00000000000000#!/usr/bin/env perl # test simple type restriction use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 76; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); # # In range # test_rw($schema, "test1" => <<__XML, 12); 12 __XML test_rw($schema, "test2" => <<__XML, 13); 13 __XML test_rw($schema, "test3" => <<__XML, 14); 14 __XML # # too small # test_rw($schema, "test1" => <<__XML, 5); 5 __XML my $error = error_r($schema, test2 => <<__XML); 6 __XML is($error, 'too small inclusive 6, min 10 at {http://test-types}test2#facet'); $error = error_w($schema, test2 => 6); is($error, "too small inclusive 6, min 10 at {http://test-types}test2#facet"); # inherited restriction $error = error_r($schema, test3 => <<__XML); 6 __XML is($error, 'too small inclusive 6, min 10 at {http://test-types}test3#facet'); $error = error_w($schema, test3 => 6); is($error, "too small inclusive 6, min 10 at {http://test-types}test3#facet"); # # too large # test_rw($schema, "test1" => <<__XML, 55); 55 __XML test_rw($schema, "test2" => <<__XML, 56); 56 __XML $error = error_r($schema, test3 => <<__XML); 57 __XML is($error, 'too large inclusive 57, max 20 at {http://test-types}test3#facet'); $error = error_w($schema, test3 => 57); is($error, "too large inclusive 57, max 20 at {http://test-types}test3#facet"); XML-Compile-1.64/t/64xsi.t0000644000175000001440000000162314703742164015627 0ustar00markovusers00000000000000#!/usr/bin/env perl # xsi_type_everywhere use warnings; use strict; use lib 'lib','t'; use TestTools; use Data::Dumper; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 6; set_compile_defaults elements_qualified => 'NONE' , xsi_type_everywhere => 1; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $w1 = writer_create $schema, "nameless with attrs" => "{$TestNS}test1"; my $w1b = writer_test($w1, { count => 3, id => 6}); compare_xml($w1b, '3'); XML-Compile-1.64/t/34abstract.t0000644000175000001440000000236014703742164016623 0ustar00markovusers00000000000000#!/usr/bin/env perl # test abstract elements use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 11; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $error = error_w($schema, test2 => {test1 => 42}); is($error, "attempt to instantiate abstract element `test1' at {http://test-types}test2/me:test1"); $error = error_r($schema, test2 => <<__XML); 43 __XML is($error, "abstract element `test1' used at {http://test-types}test2/me:test1"); # abstract elements are skipped from the docs my $out = templ_perl($schema, "{$TestNS}test2", abstract_types => 1, skip_header => 1); is($out, <<'__TEMPL'); # Describing complex x0:test2 # {http://test-types}test2 # is an unnamed complex { # sequence of test1 # is a xs:int # ABSTRACT test1 => 42, } __TEMPL XML-Compile-1.64/t/54nil.t0000644000175000001440000002134714703742164015612 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 153; use XML::Compile::Util qw/SCHEMA2001i/; my $xsi = SCHEMA2001i; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); #rt.cpan.org #39215 __SCHEMA__ ok(defined $schema); set_compile_defaults include_namespaces => 1 , elements_qualified => 'NONE'; # # simple element type # test_rw($schema, test1 => <<_XML, {e1 => 42, e2 => 43, e3 => 44} ); 424344 _XML test_rw($schema, test1 => <<_XML, {e1 => 42, e2 => 'NIL', e3 => 44} ); 4244 _XML my %t1c = (e1 => 42, e2 => 'NIL', e3 => 44); test_rw($schema, test1 => <<_XML, \%t1c, <<_XMLWriter); 4244 _XML 4244 _XMLWriter { my $error = error_r($schema, test1 => <<_XML); 45 _XML is($error,"illegal value `' for type {http://www.w3.org/2001/XMLSchema}int at {http://test-types}test1/e1"); } { my %t1b = (e1 => undef, e2 => undef, e3 => 45); my $error = error_w($schema, test1 => \%t1b); is($error, "required value for element `e1' missing at {http://test-types}test1"); } { my $error = error_r($schema, test1 => <<_XML); 8788 _XML is($error, "data for element or block starting with `e2' missing at {http://test-types}test1"); } # # fix broken specifications # set_compile_defaults interpret_nillable_as_optional => 1 , elements_qualified => 'NONE'; #my %t1d = (e1 => 89, e2 => undef, e3 => 90); my %t1d = (e1 => 89, e3 => 90); my %t1e = (e1 => 91, e2 => 'NIL', e3 => 92); test_rw($schema, test1 => <<_XML, \%t1d, <<_XML, \%t1e); 8990 _XML 9192 _XML # # rt.cpan.org #39215 # set_compile_defaults # reset include_namespaces => 1 , elements_qualified => 'NONE'; test_rw($schema, test2 => <<_XML, {roleId => 'NIL'}); _XML test_rw($schema, roleId => <<_XML, 'NIL'); _XML # # test3 & test4 based on question by Zbigniew Lukasiak, 24 Nov 2008 # test_rw($schema, test3 => <<_XML, { e3 => [ 'NIL', 42, 'NIL', 43, 'NIL' ]}); 42 43 _XML my %t4 = ( e4 => [{ _ => 'NIL'}, { 'e4b' => 51, 'e4a' => 50 }, { _ => 'NIL'}, { 'e4b' => 53, 'e4a' => 52 }, { 'e4b' => 55, 'e4a' => 54 }, { _ => 'NIL'} ] ); test_rw($schema, test4 => <<_XML, \%t4); 50 51 52 53 54 55 _XML # # Bug discovered by Mark Blackman, 20090107 # set_compile_defaults include_namespaces => 1 , elements_qualified => 1; test_rw($schema, test1 => <<_XML, {e1 => 42, e2 => 43, e3 => 44} ); 42 43 44 _XML test_rw($schema, test1 => <<_XML, {e1 => 42, e2 => 'NIL', e3 => 44} ); 42 44 _XML # # Bugs reported by Roman Daniel rt.cpan.org#51264 # set_compile_defaults include_namespaces => 1 , elements_qualified => 1 , sloppy_integers => 1; test_rw($schema, outer => <<_XML, {}); _XML test_rw($schema, outer => <<_XML, {inner => 'NIL'}); _XML test_rw($schema, outer => <<_XML, {inner => 'aap'}); aap _XML my %a = ( addressId => 100 , address => {street => 'street', city => 'city' } ); test_rw($schema, updateAddress => <<_XML, \%a); 100
street city
_XML test_rw($schema, updateAddress => <<_XML, { addressId => 100 }); 100 _XML test_rw($schema, updateAddress => <<_XML, { addressId => 100, address => {_ => 'NIL'}}); 100
_XML test_rw($schema, start => <<_XML, {dtStart => { _ => 'NIL', myAttr => 'att' }}); _XML my $out1 = templ_perl $schema, "{$TestNS}test1", skip_header => 1; is($out1, <<'__TEMPL', 'template test1'); # Describing complex x0:test1 # {http://test-types}test1 # is an unnamed complex { # sequence of e1, e2, e3 # is a xs:int e1 => 42, # is a xs:int # is nillable, hence value or NIL e2 => 42, # is a xs:int e3 => 42, } __TEMPL my $out3 = templ_perl $schema, "{$TestNS}test4", skip_header => 1; is($out3, <<'__TEMPL', 'template test4'); # Describing complex x0:test4 # {http://test-types}test4 # is an unnamed complex { # sequence of e4 # is a x0:t4 # is nillable, as: e4 => NIL # occurs 0 <= # <= 12 times e4 => [ { # sequence of e4a, e4b # is a xs:int e4a => 42, # is a xs:int e4b => 42, }, ], } __TEMPL my $out2 = templ_perl $schema, "{$TestNS}start", skip_header => 1; is($out2, <<'__TEMPL', 'template start'); # Describing complex x0:start # {http://test-types}start # is an unnamed complex { # sequence of dtStart # is an unnamed complex # dtStart is simple value with attributes dtStart => { # is a xs:string # attribute myAttr is required myAttr => "example", # is a xs:dateTime # string content of the container # is nillable, hence value or NIL _ => "2006-10-06T00:23:02Z", }, } __TEMPL XML-Compile-1.64/t/33ref.t0000644000175000001440000000540314703742164015574 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 33; my $TestNS2 = "http://second-ns"; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); # # element as reference to an element # my %r1_a = (a1_a => 10, e1_a => 11, e1_b => 12); test_rw($schema, "{$TestNS2}test4" => <<__XML, {test1 => \%r1_a}); 11 12 __XML # # element groups # my %r2_a = (e2_a => 20, g2_a => 22, g2_b => 23, e2_b => 21); test_rw($schema, test2 => <<__XML, \%r2_a); 20 22 23 21 __XML # # ref to choice # my %r3_a = (gr_g3 => [ {g3_a => 30}, {g3_a => 31}, {g3_b => 32}, {g3_a => 33} ]); test_rw($schema, test3 => <<__XML, \%r3_a); 30 31 32 33 __XML # # ref repeat # my %r5_a = (a1_a => 40, e1_a => 41, e1_b => 42); my %r5_b = (a1_a => 43, e1_a => 44, e1_b => 45); test_rw($schema, "{$TestNS2}test5" => <<__XML, {test1 => [ \%r5_a, \%r5_b ]}); 41 42 44 45 __XML XML-Compile-1.64/t/58default.t0000644000175000001440000001245114703742164016454 0ustar00markovusers00000000000000#!/usr/bin/env perl # test element default use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 91; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); set_compile_defaults elements_qualified => 'NONE' , sloppy_integers => 1; ## ### Integers ## Big-ints are checked in 49big.t test_rw($schema, "test1" => <<__XML, {t1a => 11, t1b => 12}); 1112 __XML # insert default in hash, but not when producing XML test_rw($schema, "test1" => <<__XML, {t1a => 10, t1b => 13}, <<__XML, {t1b => 13}); 13 __XML 13 __XML ## ### Strings ## my %t21 = (t2a => 'foo', t2b => 'bar', t2c => '42'); my %t22 = (t2b => 'bar'); # do not complete default in XML output test_rw($schema, "test2" => <<__XML, \%t21, <<__XML, \%t22); bar __XML bar __XML ### List # bug-report rt.cpan.org#36093 my %t31 = (e3 => ['foo', 'bar']); test_rw($schema, "test3" => <<__XML, \%t31, <<__XML, {}); __XML __XML test_rw($schema, "test3" => <<__XML, \%t31, <<__XML, {e3 => []}); __XML __XML ### various DEFAULT_VALUES modes [0.91] set_compile_defaults sloppy_integers => 1 , elements_qualified => 'NONE' , default_values => 'EXTEND'; test_rw($schema, test4 => <<__XML, {e4a => 9, e4b => 10, a4c => 11, a4d => 12}); 910 __XML my $r4a = reader_create $schema, 'reader extend', "{$TestNS}test4"; my $h4a = $r4a->( <<__XML ); 2021 __XML is_deeply($h4a, {e4a => 20, e4b => 72, a4d => 73, e4e => 21}); $h4a = $r4a->( <<__XML ); 237224 __XML is_deeply($h4a, {e4a => 23, e4b => 72, a4c => 22, a4d => 73, e4e => 24}); my $w4a = writer_create $schema, 'writer extend', "{$TestNS}test4"; my $x4a = writer_test $w4a, {e4a => 25}; compare_xml($x4a, <<__XML); 25 72 __XML # IGNORE set_compile_defaults sloppy_integers => 1 , elements_qualified => 'NONE' , default_values => 'IGNORE'; test_rw($schema, test4 => <<__XML, {e4a => 9, e4b => 10, a4c => 11, a4d => 12}); 910 __XML my $r4b = reader_create $schema, 'reader ignore', "{$TestNS}test4"; my $h4b = $r4b->( <<__XML ); 3031 __XML is_deeply($h4b, {e4a => 30, e4e => 31}); $h4b = $r4b->( <<__XML ); 337234 __XML is_deeply($h4b, {e4a => 33, e4b => 72, a4c => 32, a4d => 73, e4e => 34}); my $w4b = writer_create $schema, 'writer ignore', "{$TestNS}test4"; my $x4b = writer_test $w4b, {e4a => 35}; compare_xml($x4b, '35'); # MINIMAL set_compile_defaults sloppy_integers => 1 , elements_qualified => 'NONE' , default_values => 'MINIMAL'; test_rw($schema, test4 => <<__XML, {e4a => 9, e4b => 10, a4c => 11, a4d => 12}); 910 __XML my $r4c = reader_create $schema, 'reader minimal', "{$TestNS}test4"; my $h4c = $r4c->( <<__XML ); 4041 __XML is_deeply($h4c, {e4a => 40, e4e => 41}); $h4c = $r4c->( <<__XML ); 437244 __XML is_deeply($h4c, {e4a => 43, a4c => 42, e4b => undef, e4e => 44}); my $w4c = writer_create $schema, 'writer minimal', "{$TestNS}test4"; my $x4c = writer_test $w4c, {a4c => 45, a4d => 73, e4a => 46, e4b => 72, e4e => 47}; compare_xml($x4c, <<__XML); 46 47 __XML # Philip Garrett 2012-03-12 my $r5c = reader_create $schema, 'reader default', "{$TestNS}test5"; my $h5c = $r5c->( <<__XML ); F __XML is_deeply($h5c, {_ => 'F', a5 => 'abc'} ); XML-Compile-1.64/t/48subst.t0000644000175000001440000001071714703742164016172 0ustar00markovusers00000000000000#!/usr/bin/env perl # SubstitutionGroups use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 65; use Log::Report 'try'; set_compile_defaults elements_qualified => 'NONE'; my $TestNS2 = "http://second-ns"; my $schema = XML::Compile::Schema->new( <<__SCHEMA ); __SCHEMA ok(defined $schema); try { test_rw($schema, test1 => <<__XML, undef) }; 424344 __XML my $e = $@; # fragile ok($e, 'compile-time error'); my $error = $e->wasFatal; is("$error", "error: data for element or block starting with `head' missing at {$TestNS}test1\n"); $schema->importDefinitions( <<__EXTRA ); __EXTRA my %t1 = (t1 => 42, alt1 => {a1 => 43}, t3 => 44); test_rw($schema, test1 => <<__XML, \%t1); 424344 __XML my %t2 = (t1 => 45, alt2 => {a2 => 46}, t3 => 47); test_rw($schema, test1 => <<__XML, \%t2); 454647 __XML # abstract within substitutionGroup $error = error_r $schema, test1 => <<__XML; 101112 __XML is($error, "abstract element `head' used at {$TestNS}test1/one:head"); ### test2 my %t3 = ( head => [ {alt1 => {a1 => 50}} , {alt1 => {a1 => 51}} , {alt2 => {a2 => 52}} ] , id2 => 53 ); test_rw($schema, test2 => <<__XML, \%t3); 50 51 52 53 __XML my %t4 = (id2 => 54); test_rw($schema, test2 => <<__XML, \%t4); 54 __XML my %t5 = ( head => [ {alt2 => {a2 => 55}} , {alt1 => {a1 => 56}} ] , id2 => 57 ); test_rw($schema, test2 => <<__XML, \%t5); 55 56 57 __XML # Optional and unbounded my %t6 = ( head => [ {alt2 => {a2 => 70}} , {alt1 => {a1 => 71}} ] , id3 => 72 ); test_rw($schema, test3 => <<__XML, \%t6); 70 71 72 __XML ### multi-level $schema->importDefinitions( <<__EXTRA ); __EXTRA my %t7 = (head => [ {alt3 => 61} ], id2 => 62); test_rw($schema, test2 => <<__XML, \%t7); 61 62 __XML my $out = templ_perl $schema, "{$TestNS}test2", skip_header => 1 , abstract_types => 1; is($out, <<'__TEMPL'); # Describing complex x0:test2 # {http://test-types}test2 # is an unnamed complex { # sequence of head, id2 # substitutionGroup x0:head # alt1 unnamed complex # alt2 unnamed complex # alt3 xs:int # head xs:string (abstract) # occurs 0 <= # <= 3 times head => [ { alt1 => {...} }, ], # is a xs:int id2 => 42, } __TEMPL XML-Compile-1.64/t/73rewrite.t0000644000175000001440000000672314703742164016513 0ustar00markovusers00000000000000#!/usr/bin/env perl # Test key rewrite use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; #use Log::Report mode => 3; use Test::More tests => 44; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); ### stacked rewrites my %rewrite_table = ( 't1-e3' => 'Tn3', 't1-a3' => 'Ta3' ); sub rewrite_dash { $_[1] =~ s/\-/_/g; $_[1] }; sub rewrite_lowercase { lc $_[1] } set_compile_defaults elements_qualified => 'NONE' , key_rewrite => [ \%rewrite_table, \&rewrite_dash, \&rewrite_lowercase ]; my %t1a = (t1_e1 => 42, t1e2 => 43, tn3 => 44, t1_a1 => 45, t1a2 => 46, ta3 => 47); test_rw($schema, test1 => <<__XML, \%t1a); 42 43 44 __XML ### pre-defined simplify set_compile_defaults elements_qualified => 'NONE' , key_rewrite => 'SIMPLIFIED'; my %t1b = ( t1_e1 => 45, t1e2 => 46, t1_e3 => 47 , t1_a1 => 48, t1a2 => 49, t1_a3 => 50); test_rw($schema, test1 => <<__XML, \%t1b); 45 46 47 __XML ### pre-defined prefixed set_compile_defaults elements_qualified => 'NONE' , key_rewrite => 'PREFIXED' , prefixes => [ me => $TestNS ] , elements_qualified => 1 , include_namespaces => 1; my %t3 = ('me_t1-E1' => 50, 'me_t1E2' => 51, 'me_t1-e3' => 52); test_rw($schema, test1 => <<__XML, \%t3); 50 51 52 __XML ### example from the manual-page set_compile_defaults key_rewrite => [ qw/PREFIXED SIMPLIFIED/ ] , prefixes => [ mine => $TestNS ] , elements_qualified => 'ALL'; my $r4 = reader_create $schema, 'changed prefix', "{$TestNS}test1"; my $x4 = $r4->( <<__XML ); 60 61 62 __XML is_deeply($x4, {mine_t1_e1 => 60, mine_t1e2 => 61, mine_t1_e3 => 62}); ### substitutionGroup set_compile_defaults key_rewrite => sub { uc $_[1] } , include_namespaces => 1 , elements_qualified => 'ALL'; test_rw($schema, test2 => <<__XML, {T2A => 70}); 70 __XML test_rw($schema, test2 => <<__XML, {T2B => 71}); 71 __XML my $out = templ_perl $schema, "{$TestNS}test2" , key_rewrite => sub {uc $_[1]}, skip_header => 1; # T2B "borrows" type of base type is($out, <<'__TEMPL'); # Describing complex x0:test2 # {http://test-types}test2 # is an unnamed complex { # sequence of T2A # substitutionGroup x0:t2a # T2A xs:int # T2B xs:int T2A => { T2A => 42 }, } __TEMPL XML-Compile-1.64/t/39ns.t0000644000175000001440000000706014703742164015447 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 52; my $NS2 = "http://test2/ns"; # as wrapper to group two schema's, is ignored. my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); is(join("\n", join "\n", $schema->types)."\n", <<__TYPES__); {http://test-types}ct1 {http://test-types}ct5 {http://test2/ns}ct6 __TYPES__ is(join("\n", join "\n", $schema->elements)."\n", <<__ELEMS__); {http://test-types}test1 {http://test-types}test2 {http://test-types}test5 {http://test2/ns}test3 {http://test2/ns}test4 {http://test2/ns}test6 __ELEMS__ set_compile_defaults elements_qualified => 'ALL' , attributes_qualified => 1 , include_namespaces => 1 , use_default_namespace => 0 , prefixes => [b => $NS2]; # # simple name-space on schema # ok(1, "** Testing simple namespace"); test_rw($schema, test1 => <<_XML, 10); 10 _XML test_rw($schema, "test2" => <<_XML, {c1_a => 11}); 11 _XML test_rw($schema, "{$NS2}test3" => <<_XML, {c1_a => 12, a1_a => 13}); 12 _XML my %t4 = (c1_a => 14, a1_a => 15, c4_a => 16, a4_a => 17); test_rw($schema, "{$NS2}test4" => <<_XML, \%t4); 14 16 _XML # now with name-spaces off set_compile_defaults ignore_namespaces => 1 , elements_qualified => 'NONE'; test_rw($schema, "{$NS2}test3" => <<_XML, {c1_a => 18}); 18 _XML # # Test 5/6 # set_compile_defaults elements_qualified => 'ALL' , ignore_namespaces => 0 , include_namespaces => 1; my %h6 = (e5a => 42, e6a => 'aap'); test_rw($schema, "{$NS2}test6" => <<_XML, \%h6); 42 aap _XML # # Test 7 # element in "wrong" namespace. # # #test_rw($schema, "{$TestNS}test7" => <<_XML, 43); #43 #_XML XML-Compile-1.64/t/47ctsres.t0000644000175000001440000000372114703742164016331 0ustar00markovusers00000000000000#!/usr/bin/env perl # test complex type simpleContent restrictions use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 33; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my %t1 = (_ => 11, a1_a => 10); test_rw($schema, test1 => <<_XML, \%t1); 11 _XML my %t2 = (_ => 12, a2_a => 13); test_rw($schema, test2 => <<_XML, \%t2); 12 _XML my %t3 = (_ => 14, a3_a => 15); test_rw($schema, test3 => <<_XML, \%t3); 14 _XML # test 4, report rt.cpan.org#46212 by Erich Weigand test_rw($schema, test4 => <<_XML, { language => 'de', _ => 'Hallo Welt' } ); Hallo Welt _XML XML-Compile-1.64/t/50union.t0000644000175000001440000000652114703742164016151 0ustar00markovusers00000000000000#!/usr/bin/env perl # simpleType union use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 143; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $error; ### test1 test_rw($schema, test1 => <<__XML, 1 ); 1 __XML test_rw($schema, test1 => <<__XML, 0 ); 0 __XML test_rw($schema, test1 => <<__XML, 'unbounded'); unbounded __XML $error = error_r($schema, test1 => <<__XML); other __XML is($error, "no match for `other' in union at {http://test-types}test1#union"); $error = error_w($schema, test1 => 'other'); is($error, "no match for `other' in union at {http://test-types}test1#union"); ### test3 test_rw($schema, test3 => <<__XML, 1 ); 1 __XML test_rw($schema, test3 => <<__XML, 'any'); any __XML test_rw($schema, test3 => <<__XML, 'none'); none __XML $error = error_r($schema, test3 => <<__XML); other __XML is($error, "no match for `other' in union at {http://test-types}test3#union"); $error = error_w($schema, test3 => 'other'); is($error, "no match for `other' in union at {http://test-types}test3#union"); ### test4 test_rw($schema, test4 => "2011-07-06", '2011-07-06'); test_rw($schema, test4 => "2011-07-06T10:06:24", '2011-07-06T10:06:24'); test_rw($schema, test4 => "2011-07-06T10:06:54Z", '2011-07-06T10:06:54Z'); test_rw($schema, test4 => "2011-07-06T10:10:32+02:00", '2011-07-06T10:10:32+02:00'); ### test5 test_rw($schema, test5 => '1 2 3 4', [1..4]); test_rw($schema, test5 => '3 NIL NIL 7', [3,'NIL','NIL',7]); $error = error_r($schema, test5 => 'A 42'); is($error, "no match for `A' in union at {http://test-types}test5#union"); test_rw($schema, test5b => '0', 0); test_rw($schema, test5 => '0', [0]); test_rw($schema, test5 => '0 0', [0, 0]); XML-Compile-1.64/t/30compile.t0000644000175000001440000000414214703742164016444 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 14; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); # # Direct schema access # my $dirr = $schema->compile(READER => "{$SchemaNS}int"); ok(defined $dirr, 'read an int'); my $val = $dirr->('40'); cmp_ok($val, '==', 40); my $dirw = $schema->compile(WRITER => "{$SchemaNS}int"); my $doc = XML::LibXML->createDocument('1.0', 'UTF-8'); ok(defined $dirw, 'write an int'); my $node = $dirw->($doc, '41'); ok(ref $node, 'created XML node'); isa_ok($node, 'XML::LibXML::Text'); compare_xml($node, '41'); # # simple element type # my $read_t1 = $schema->compile ( READER => "{$TestNS}test1" , check_values => 1 ); ok(defined $read_t1, "reader element test1"); cmp_ok(ref($read_t1), 'eq', 'CODE'); my $t1 = $read_t1->( <<__XML ); 42 __XML cmp_ok($t1, '==', 42); # # the simpleType, less simple type # my $read_t2 = $schema->compile ( READER => "{$TestNS}test2" , check_values => 1 ); ok(defined $read_t2, "reader simpleType test2"); cmp_ok(ref($read_t2), 'eq', 'CODE'); my $hash = $read_t2->( <<__XML ); 42 __XML # # The not so complex complexType # my $read_t3 = $schema->compile ( READER => "{$TestNS}test3" , check_values => 1 ); ok(defined $read_t3, "reader complexType test3"); cmp_ok(ref($read_t3), 'eq', 'CODE'); my $hash2 = $read_t3->( <<__XML ); 13 42 __XML XML-Compile-1.64/t/43group.t0000644000175000001440000000343714703742164016162 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 33; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $error; test_rw($schema, test0 => <<__XML, {g1_a => 10, g1_b => 11}); 1011 __XML test_rw($schema, test1 => <<__XML, {g1_a => 10, g1_b => 11, t1a => 'a', t1b => 'b'}); a1011b __XML my %g2a = (gr_g1 => [ { g1_a => 12, g1_b => 13} , { g1_a => 14, g1_b => 15} ] ); test_rw($schema, test2 => <<__XML, \%g2a); 1213 1415 __XML test_rw($schema, test3 => <<__XML, {}); __XML XML-Compile-1.64/t/46ctsext.t0000644000175000001440000000302514703742164016334 0ustar00markovusers00000000000000#!/usr/bin/env perl # test complex type simpleContent extensions use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 33; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my %t1 = (_ => 11, a2_a => 16); test_rw($schema, "test1" => <<__XML, \%t1); 11 __XML my %t2 = (_ => 12, a3_a => 17); test_rw($schema, "test2" => <<__XML, \%t2); 12 __XML test_rw($schema, "test2" => <<__XML, {_ => 14}); 14 __XML my %t3 = (_ => 30, a2_a => 31, a4 => 32); test_rw($schema, "test3" => <<__XML, \%t3); 30 __XML XML-Compile-1.64/t/42all.t0000644000175000001440000001174414703742164015575 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 182; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $error; test_rw($schema, test1 => <<__XML, {t1_a => 10}); 10 __XML $error = error_r($schema, test1 => <<__XML); 89 __XML is($error, "element `extra' not processed for {http://test-types}test1 at /test1/extra"); # all itself is not a all, unless minOccurs=0 $error = error_r($schema, test1 => <<__XML); __XML is($error, "data for element or block starting with `t1_a' missing at {http://test-types}test1"); test_rw($schema, test1 => undef, {}); test_rw($schema, test2 => <<__XML, {t2_a => 11}); 11 __XML # test 3 foreach my $f ( [qw/t3_a t3_b t3_c/ ] , [qw/t3_a t3_c t3_b/ ] , [qw/t3_b t3_a t3_c/ ] , [qw/t3_b t3_c t3_a/ ] , [qw/t3_c t3_a t3_b/ ] , [qw/t3_c t3_b t3_a/ ] ) { my %f = ( $f->[0] => 13, $f->[1] => 14, $f->[2] => 15 ); ok(1, "try $f->[0], $f->[1], $f->[2]"); test_rw($schema, test3 => <<__XML, \%f, <<__XMLWriter); <$f->[0]>13[0]> <$f->[1]>14[1]> <$f->[2]>15[2]> __XML $f{t3_a} $f{t3_b} $f{t3_c} __XMLWriter $error = error_r($schema, test3 => <<__XML); <$f->[0]>13[0]> <$f->[1]>14[1]> __XML is($error, "data for element or block starting with `$f->[2]' missing at {http://test-types}test3"); $error = error_r($schema, test3 => <<__XML); <$f->[0]>13[0]> __XML like($error, qr/^data for element or block starting with `.*' missing at \{http\:\/\/test-types\}test3$/); } # test 4 test_rw($schema, test4 => <<__XML, {t4_a=>16, t4_b=>17, t4_c=>18, t4_d=>19}); 16171819 __XML my %t4b = (t4_a=>20, t4_b=>22, t4_c=>23, t4_d=>21); test_rw($schema, test4 => <<__XML, \%t4b, <<__XML2); 20212223 __XML 20222321 __XML2 $error = error_r($schema, test4 => <<__XML); 24252627 __XML is($error, "data for element or block starting with `t4_b' missing at {http://test-types}test4"); # test 5 my %t5_a = ( all_t5_a => [ { t5_a => 23 , t5_b => 24 , t5_c => 25 } ] ); test_rw($schema, test5 => <<__XML, \%t5_a); 232425 __XML my %t5_b = (all_t5_a => [ { t5_a => 30 , t5_b => 31 , t5_c => 32 } , { t5_a => 35 , t5_b => 34 , t5_c => 33 } ]); test_rw($schema, test5 => <<__XML, \%t5_b, <<__XML2); 303132 333435 __XML 303132 353433 __XML2 test_rw($schema, test5 => '', {}); # test 6 $error = error_r($schema, test6 => ''); like($error, qr[data for element or block starting with `t6_[abc]' missing at \{http://test-types\}test6]); $error = error_w($schema, test6 => {}); is($error, "found 0 blocks for `all_t6_a', must be between 1 and 3 inclusive at {http://test-types}test6"); XML-Compile-1.64/t/45ctcres.t0000644000175000001440000000217414703742164016310 0ustar00markovusers00000000000000#!/usr/bin/env perl # test complex type restrictions use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 9; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my %t1 = (a1_a => 13, a1_b => 14, t2_a => 15, a2_a => 16); test_rw($schema, "test1" => <<__XML, \%t1); 15 __XML XML-Compile-1.64/t/56pats.t0000644000175000001440000000172414703742164015776 0ustar00markovusers00000000000000#!/usr/bin/env perl # patterns are still poorly supported. use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 18; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $error; test_rw($schema, "test1" => <<__XML, "abc"); abc __XML $error = error_r($schema, test1 => <<__XML); abbc __XML is($error, "string `abbc' does not match pattern `a.c' at {http://test-types}test1#facet"); $error = error_w($schema, test1 => 'abbc'); is($error, "string `abbc' does not match pattern `a.c' at {http://test-types}test1#facet"); XML-Compile-1.64/t/32attr.t0000644000175000001440000000736014703742164015775 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More tests => 95; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); ## test 1 my %t1 = (t1_a => 10, t1_b => 9, a1_a => 11, a1_b => 12); test_rw($schema, test1 => <<__XML, \%t1); 10 9 __XML my %t1_b = (t1_a => 20, t1_b => 21, a1_b => 23); test_rw($schema, test1 => <<__XML, \%t1_b); 20 21 __XML my $error = error_r($schema, test1 => <<__XML); 25 26 __XML is($error, "attribute `a1_b' is required at {http://test-types}test1/\@a1_b"); my %t1_c = (a1_b => 24, t1_a => 25); $error = error_w($schema, test1 => \%t1_c); is($error, "required value for element `t1_b' missing at {http://test-types}test1"); ## test 2 attributeGroup my %t2_a = (a2_a => 30, a2_b => 31, a2_c => 29, t2_b => 100); test_rw($schema, test2 => <<__XML, \%t2_a); 100 __XML my %t2_b = (a2_a => 32, a2_b => 33, a2_c => 34, a2_d => 35 , t2_a => 99, t2_b => 101); test_rw($schema, test2 => <<__XML, \%t2_b); 99101 __XML $error = error_r($schema, test2 => <<__XML); 102 __XML is($error, "attribute `a2_e' is prohibited at {http://test-types}test2/\@a2_e"); $error = error_w($schema, test2 => {a2_c => 29, a2_e => 666, t2_b => 77} ); is($error, "attribute `a2_e' is prohibited at {http://test-types}test2/\@a2_e"); test_rw($schema, test3 => '', { a3 => 41 }); ### toplevel attributes # test 4 test_rw($schema, test4 => '', { a4 => 42 }); test_rw($schema, a4 => XML::LibXML::Attr->new('a4', 43), 43, ' a4="43"'); # test 5 test_rw($schema, test5 => '', { a5 => 'only-one' }); $error = error_r($schema, test5 => ''); is($error, "invalid enumerate `not-two' at {http://test-types}test5#facet"); test_rw($schema, a5 => XML::LibXML::Attr->new(a5 => 'only-one') , 'only-one', ' a5="only-one"'); XML-Compile-1.64/t/59big.t0000644000175000001440000000530414703742164015571 0ustar00markovusers00000000000000#!/usr/bin/env perl # test use of big math use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use Test::More; BEGIN { eval 'require Math::BigInt'; if($@) { plan skip_all => "Math::BigInt not installed"; } plan tests => 66; } # Will fail when perl's longs get larger than 64bit my $some_big1 = "12432156239876121237"; my $some_big2 = "243587092790745290879"; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); set_compile_defaults elements_qualified => 'NONE' , sloppy_integers => 0; ## ### Integers ## test_rw($schema, "test1" => <<__XML, 12); 12 __XML test_rw($schema, "test1" => <<__XML, Math::BigInt->new($some_big1)); $some_big1 __XML test_rw($schema, "test2" => <<__XML, 42); 42 __XML test_rw($schema, "test2" => <<__XML, Math::BigInt->new($some_big1)); $some_big1 __XML # limit to huge maxInclusive my $error = error_r($schema, test2 => <<__XML); $some_big2 __XML is($error, 'too large inclusive 243587092790745290879, max 12432156239876121237 at {http://test-types}test2#facet'); $error = error_w($schema, test2 => Math::BigInt->new($some_big2)); is($error, 'too large inclusive 243587092790745290879, max 12432156239876121237 at {http://test-types}test2#facet'); # ## Big defaults # my %t31 = (t3a => Math::BigInt->new($some_big1), t3b => 13); test_rw($schema, "test3" => <<__XML, \%t31); $some_big113 __XML my %t34 = (t3a => Math::BigInt->new($some_big2), t3b => 11); test_rw($schema, test3 => <<__XML, \%t34, <<__XML, {t3b => 11}); __XML 11 __XML # ## Big fixed # my $bi4 = Math::BigInt->new($some_big2); test_rw($schema, test4 => <<__XML, {t4 => $bi4}, <<__XML, {t4 => $bi4}); $some_big2 __XML $some_big2 __XML XML-Compile-1.64/t/55facet_date.t0000644000175000001440000000203414703742164017100 0ustar00markovusers00000000000000#!/usr/bin/env perl # test facets on dates, shares some with numeric facets use warnings; use strict; use lib 'lib','t'; use TestTools; use XML::Compile::Schema; use XML::Compile::Tester; use XML::Compile::Util qw/pack_type/; use Test::More tests => 9; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ );                              __SCHEMA__ ok(defined $schema); set_compile_defaults include_namespaces => 0 , elements_qualified => 'NONE' , use_default_namespace => 0; test_rw($schema, test1 => '2012-01-01T00:00:00Z' , '2012-01-01T00:00:00Z'); XML-Compile-1.64/lib/0000755000175000001440000000000014705455321014764 5ustar00markovusers00000000000000XML-Compile-1.64/lib/XML/0000755000175000001440000000000014705455321015424 5ustar00markovusers00000000000000XML-Compile-1.64/lib/XML/Compile/0000755000175000001440000000000014705455321017014 5ustar00markovusers00000000000000XML-Compile-1.64/lib/XML/Compile/Schema/0000755000175000001440000000000014705455321020214 5ustar00markovusers00000000000000XML-Compile-1.64/lib/XML/Compile/Schema/BuiltInFacets.pod0000644000175000001440000000177314705455304023425 0ustar00markovusers00000000000000=encoding utf8 =head1 NAME XML::Compile::Schema::BuiltInFacets - handling of built-in facet checks =head1 INHERITANCE XML::Compile::Schema::BuiltInFacets is an Exporter =head1 SYNOPSIS # Not for end-users use XML::Compile::Schema::BuiltInFacets qw/builtin_facet/ =head1 DESCRIPTION This package implements the facet checks. Facets are used to express restrictions on variable content which need to be checked dynamically. The content is not for end-users, but called by the schema translator. =head1 FUNCTIONS =over 4 =item B( $path, $args, $type, [$value] ) =back =head1 SEE ALSO This module is part of XML-Compile distribution version 1.64, built on October 21, 2024. Website: F =head1 LICENSE Copyrights 2006-2024 by [Mark Overmeer ]. For other contributors see ChangeLog. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F XML-Compile-1.64/lib/XML/Compile/Schema/BuiltInTypes.pm0000644000175000001440000004110114705455267023153 0ustar00markovusers00000000000000# Copyrights 2006-2024 by [Mark Overmeer ]. # For other contributors see ChangeLog. # See the manual pages for details on the licensing terms. # Pod stripped from pm file by OODoc 2.03. # This code is part of distribution XML-Compile. Meta-POD processed with # OODoc into POD and HTML manual-pages. See README.md # Copyright Mark Overmeer. Licensed under the same terms as Perl itself. package XML::Compile::Schema::BuiltInTypes;{ our $VERSION = '1.64'; } use base 'Exporter'; use warnings; use strict; use utf8; no warnings 'recursion'; our @EXPORT = qw/%builtin_types builtin_type_info/; our %builtin_types; use Log::Report 'xml-compile'; use POSIX qw/strftime/; use Math::BigInt; use Math::BigFloat; use MIME::Base64; use Types::Serialiser; use Scalar::Util qw(dualvar); use POSIX qw/floor log10/; use XML::Compile::Util qw/pack_type unpack_type/; use Config '%Config'; my $iv_bits = $Config{ivsize} * 8 -1; my $iv_digits = floor($iv_bits * log10(2)); my $fits_iv = qr/^[+-]?[0-9]{1,$iv_digits}$/; sub builtin_type_info($) { $builtin_types{$_[0]} } # The XML reader calls # check(parse(value)) or check_read(parse(value)) # The XML writer calls # check(format(value)) or check_write(format(value)) # Parse has a second argument, only for QNAME: the node # Format has a second argument for QNAME as well. sub identity { $_[0] } # already validated, unless that is disabled. sub str2int { $_[0] + 0 } # sprintf returns '0' if non-int, with warning. We need a validation error sub int2str { $_[0] =~ m/^\s*([0-9]+)\s*$/ ? $1 : $_[0] } sub str { "$_[0]" } sub _replace { $_[0] =~ s/[\t\r\n]/ /g; $_[0]} sub _collapse { local $_ = $_[0]; s/[\t\r\n]+/ /g; s/^ +//; s/ +$//; $_} # format not useful, because xsi:type not supported $builtin_types{anySimpleType} = { example => 'anySimple' , parse => sub {shift} , extends => 'anyType' }; $builtin_types{anyType} = { example => 'anything' , parse => sub {shift} , extends => undef # the root type }; $builtin_types{anyAtomicType} = { example => 'anyAtomic' , parse => sub {shift} , extends => 'anySimpleType' }; $builtin_types{error} = {example => '[some error structure]'}; #---------------- $builtin_types{boolean} = { parse => sub { $_[0] =~ m/^\s*false|0\s*/i ? 0 : 1 } , format => sub { $_[0] eq 'false' || $_[0] eq 'true' ? $_[0] : $_[0] ? 1 : 0 } , check => sub { $_[0] =~ m/^\s*(?:false|true|0|1)\s*$/i } , example => 'true' , extends => 'anyAtomicType' }; $builtin_types{boolean_with_Types_Serialiser} = { %{$builtin_types{boolean}} , parse => sub { no warnings 'once'; $_[0] =~ m/^\s*(false|0)\s*/i ? $Types::Serialiser::false : $Types::Serialiser::true; } }; $builtin_types{pattern} = { example => '*.exe' }; sub bigint { my $v = shift; $v =~ s/\s+//g; # The automatic rewrite into JSON wants real ints, not strings. Therefore, # we need to numify. On the other hand, pattern matching/enumeration # requires the original string. Regression tests prove this trick works. return dualvar($v+0, $v) if $v =~ $fits_iv; my $big = Math::BigInt->new($v); error __x"Value `{val}' is not a (big) integer", val => $big if $big->is_nan; $big; } $builtin_types{integer} = { parse => \&bigint , check => sub { $_[0] =~ m/^\s*[-+]?\s*[0-9][\s0-9]*$/ } , example => 42 , extends => 'decimal' }; $builtin_types{negativeInteger} = { parse => \&bigint , check => sub { $_[0] =~ m/^\s*\-\s*[0-9][\s0-9]*$/ } , example => '-1' , extends => 'nonPositiveInteger' }; $builtin_types{nonNegativeInteger} = { parse => \&bigint , check => sub { $_[0] =~ m/^\s*(?:\+\s*)?[0-9][\s0-9]*$/ } , example => '17' , extends => 'integer' }; $builtin_types{positiveInteger} = { parse => \&bigint , check => sub { $_[0] =~ m/^\s*(?:\+\s*)?[0-9][\s0-9]*$/ && $_[0] =~ m/[1-9]/ } , example => '+3' , extends => 'nonNegativeInteger' }; $builtin_types{nonPositiveInteger} = { parse => \&bigint , check => sub { $_[0] =~ m/^\s*(?:\-\s*)?[0-9][\s0-9]*$/ || $_[0] =~ m/^\s*(?:\+\s*)0[0\s]*$/ } , example => '-42' , extends => 'integer' }; $builtin_types{long} = { parse => \&bigint , check => sub { $_[0] =~ m/^\s*[-+]?\s*[0-9][\s0-9]*$/ && ($_[0] =~ tr/0-9//) < 20 } , example => '-100' , extends => 'integer' }; $builtin_types{unsignedLong} = { parse => \&bigint , check => sub {$_[0] =~ m/^\s*\+?\s*[0-9][\s0-9]*$/ && ($_[0] =~ tr/0-9//) < 21} , example => '100' , extends => 'nonNegativeInteger' }; $builtin_types{unsignedInt} = { parse => \&bigint , check => sub {$_[0] =~ m/^\s*\+?\s*[0-9][\s0-9]*$/ && ($_[0] =~ tr/0-9//) <=10} , example => '42' , extends => 'unsignedLong' }; # Used when 'sloppy_integers' was set: the size of the values # is illegally limited to the size of Perl's 32-bit signed integers. $builtin_types{non_pos_int} = { parse => \&str2int , format => \&int2str , check => sub {$_[0] =~ m/^\s*[+-]?\s*[0-9][0-9\s]*$/ && $_[0] <= 0} , example => '-12' }; $builtin_types{positive_int} = { parse => \&str2int , format => \&int2str , check => sub {$_[0] =~ m/^\s*(?:\+\s*)?[0-9][0-9\s]*$/ } , example => '+42' }; $builtin_types{negative_int} = { parse => \&str2int , format => \&int2str , check => sub {$_[0] =~ m/^\s*\-\s*[0-9][0-9\s]*$/ } , example => '-12' }; $builtin_types{unsigned_int} = { parse => \&str2int , format => \&int2str , check => sub {$_[0] =~ m/^\s*(?:\+\s*)?[0-9][0-9\s]*$/ && $_[0] >= 0} , example => '42' }; $builtin_types{int} = { parse => \&str2int , format => \&int2str , check => sub {$_[0] =~ m/^\s*[+-]?[0-9]+\s*$/} , example => '42' , extends => 'long' }; $builtin_types{short} = { parse => \&str2int , format => \&int2str , check => sub { $_[0] =~ m/^\s*[+-]?[0-9]+\s*$/ && $_[0] >= -32768 && $_[0] <= 32767 } , example => '-7' , extends => 'int' }; $builtin_types{unsignedShort} = { parse => \&str2int , format => \&int2str , check => sub { $_[0] =~ m/^\s*[+-]?[0-9]+\s*$/ && $_[0] >= 0 && $_[0] <= 65535 } , example => '7' , extends => 'unsignedInt' }; $builtin_types{byte} = { parse => \&str2int , format => \&int2str , check => sub {$_[0] =~ m/^\s*[+-]?[0-9]+\s*$/ && $_[0] >= -128 && $_[0] <=127} , example => '-2' , extends => 'short' }; $builtin_types{unsignedByte} = { parse => \&str2int , format => \&int2str , check => sub {$_[0] =~ m/^\s*[+-]?[0-9]+\s*$/ && $_[0] >= 0 && $_[0] <= 255} , example => '2' , extends => 'unsignedShort' }; $builtin_types{decimal} = { parse => sub {$_[0] =~ s/\s+//g; Math::BigFloat->new($_[0]) }, , check => sub {$_[0] =~ m/^(\+|\-)?([0-9]+(\.[0-9]*)?|\.[0-9]+)$/} , example => '3.1415' , extends => 'anyAtomicType' }; sub str2num { my $s = shift; $s =~ s/\s//g; $s =~ m/[^0-9]/ ? Math::BigFloat->new($s eq 'NaN' ? $s : lc $s) # INF->inf : length $s < 9 ? dualvar($s+0, $s) : Math::BigInt->new($s); } sub num2str { my $f = shift; !ref $f ? $f : !(UNIVERSAL::isa($f,'Math::BigInt') || UNIVERSAL::isa($f,'Math::BigFloat')) ? eval {use warnings FATAL => 'all'; $f + 0.0} : $f->is_nan ? 'NaN' : uc $f->bstr; # [+-]inf -> [+-]INF, e->E doesn't matter } sub numcheck($) { $_[0] =~ m# [+-]? (?: [0-9]+(?:\.[0-9]*)?|\.[0-9]+) (?:[Ee][+-]?[0-9]+)? | [+-]? INF | NaN #x } $builtin_types{precisionDecimal} = $builtin_types{float} = $builtin_types{double} = { parse => \&str2num , format => \&num2str , check => \&numcheck , example => '3.1415' , extends => 'anyAtomicType' }; $builtin_types{sloppy_float} = { parse => sub { $_[0] } , check => sub { my $v = eval {use warnings FATAL => 'all'; $_[0] + 0.0}; $@ ? undef : 1; } , example => '3.1415' , extends => 'anyAtomicType' }; $builtin_types{sloppy_float_force_NV} = { %{$builtin_types{sloppy_float}} , parse => sub { $_[0] + 0 } }; $builtin_types{base64Binary} = { parse => sub { eval { decode_base64 $_[0] }; } , format => sub { my $a = $_[0]; eval { utf8::downgrade($a) }; if($@) { error __x"use Encode::encode() for base64Binary field at {path}" , path => $_[2]; } encode_base64 $a, ''; } , check => sub { !$@ } , example => 'decoded bytes' , extends => 'anyAtomicType' }; # (Use of) an XS implementation would be nice $builtin_types{hexBinary} = { parse => sub { (my $v = $_[0]) =~ s/\s+//g; pack 'H*', $v } , format => sub { uc unpack 'H*', $_[0]} , check => sub { (my $v = $_[0]) !~ m/[^0-9a-fA-F\s]/ or return 0; ($v =~ tr/0-9a-fA-F//) % 2 == 0} , example => 'F00F' , extends => 'anyAtomicType' }; my $yearFrag = qr/ \-? (?: [1-9][0-9]{3,} | 0[0-9][0-9][0-9] ) /x; my $monthFrag = qr/ 0[1-9] | 1[0-2] /x; my $dayFrag = qr/ 0[1-9] | [12][0-9] | 3[01] /x; my $hourFrag = qr/ [01][0-9] | 2[0-3] /x; my $minuteFrag = qr/ [0-5][0-9] /x; my $secondFrag = qr/ [0-5][0-9] (?: \.[0-9]+)? /x; my $endOfDayFrag = qr/24\:00\:00 (?: \.[0-9]+)? /x; my $timezoneFrag = qr/Z | [+-] (?: 0[0-9] | 1[0-4] ) \: $minuteFrag/x; my $timeFrag = qr/ (?: $hourFrag \: $minuteFrag \: $secondFrag ) | $endOfDayFrag /x; my $date = qr/^ $yearFrag \- $monthFrag \- $dayFrag $timezoneFrag? $/x; $builtin_types{date} = { parse => \&_collapse , format => sub { $_[0] =~ /^[0-9]+$/ ? strftime("%Y-%m-%d", gmtime $_[0]) : $_[0]} , check => sub { (my $val = $_[0]) =~ s/\s+//g; $val =~ $date } , example => '2006-10-06' , extends => 'anyAtomicType' }; my $time = qr /^ $timeFrag $timezoneFrag? $/x; $builtin_types{time} = { parse => \&_collapse , format => sub { return $_[0] if $_[0] =~ /[^0-9.]/; my $subsec = $_[0] =~ /(\.[0-9]+)/ ? $1 : ''; strftime "%T$subsec", gmtime $_[0] } , check => sub { (my $val = $_[0]) =~ s/\s+//g; $val =~ $time } , example => '11:12:13' , extends => 'anyAtomicType' }; my $dateTime = qr/^ $yearFrag \- $monthFrag \- $dayFrag T $timeFrag $timezoneFrag? $/x; my $dateTimeStamp = qr/^ $yearFrag \- $monthFrag \- $dayFrag T $timeFrag $timezoneFrag $/x; sub _dt_format { return $_[0] if $_[0] =~ /[^0-9.]/; # already formated my $subsec = $_[0] =~ /(\.[0-9]+)/ ? $1 : ''; strftime "%Y-%m-%dT%H:%M:%S${subsec}Z", gmtime $_[0]; } $builtin_types{dateTime} = { parse => \&_collapse , format => \&_dt_format , check => sub { (my $val = $_[0]) =~ s/\s+//g; $val =~ $dateTime } , example => '2006-10-06T00:23:02Z' , extends => 'anyAtomicType' }; $builtin_types{dateTimeStamp} = { parse => \&_collapse , format => \&_dt_format , check => sub { (my $val = $_[0]) =~ s/\s+//g; $val =~ $dateTimeStamp } , example => '2006-10-06T00:23:02Z' , extends => 'dateTime' }; my $gDay = qr/^ \- \- \- $dayFrag $timezoneFrag? $/x; $builtin_types{gDay} = { parse => \&_collapse , check => sub { (my $val = $_[0]) =~ s/\s+//g; $val =~ $gDay } , example => '---12+09:00' , extends => 'anyAtomicType' }; my $gMonth = qr/^ \- \- $monthFrag $timezoneFrag? $/x; $builtin_types{gMonth} = { parse => \&_collapse , check => sub { (my $val = $_[0]) =~ s/\s+//g; $val =~ $gMonth } , example => '--09+07:00' , extends => 'anyAtomicType' }; my $gMonthDay = qr/^ \- \- $monthFrag \- $dayFrag $timezoneFrag? /x; $builtin_types{gMonthDay} = { parse => \&_collapse , check => sub { (my $val = $_[0]) =~ s/\s+//g; $val =~ $gMonthDay } , example => '--09-12+07:00' , extends => 'anyAtomicType' }; my $gYear = qr/^ $yearFrag $timezoneFrag? $/x; $builtin_types{gYear} = { parse => \&_collapse , check => sub { (my $val = $_[0]) =~ s/\s+//g; $val =~ $gYear } , example => '2006+07:00' , extends => 'anyAtomicType' }; my $gYearMonth = qr/^ $yearFrag \- $monthFrag $timezoneFrag? $/x; $builtin_types{gYearMonth} = { parse => \&_collapse , check => sub { (my $val = $_[0]) =~ s/\s+//g; $val =~ $gYearMonth } , example => '2006-11+07:00' , extends => 'anyAtomicType' }; $builtin_types{duration} = { parse => \&_collapse , check => sub { my $val = $_[0]; $val =~ s/\s+//g; $val =~ m/^\-?P(?:[0-9]+Y)?(?:[0-9]+M)?(?:[0-9]+D)? (?:T(?:[0-9]+H)?(?:[0-9]+M)?(?:[0-9]+(?:\.[0-9]+)?S)?)?$/x } , example => 'P9M2DT3H5M' }; $builtin_types{dayTimeDuration} = { parse => \&_collapse , check => sub { my $val = $_[0]; $val =~ s/\s+//g; $val =~ m/^\-?P(?:[0-9]+D)?(?:T(?:[0-9]+H)?(?:[0-9]+M)?(?:[0-9]+(?:\.[0-9]+)?S)?)?$/ } , example => 'P2DT3H5M10S' , extends => 'duration' }; $builtin_types{yearMonthDuration} = { parse => \&_collapse , check => sub { my $val = $_[0]; $val =~ s/\s+//g; $val =~ m/^\-?P(?:[0-9]+Y)?(?:[0-9]+M)?$/ } , example => 'P40Y5M' , extends => 'duration' }; #------------- $builtin_types{string} = { example => 'example' , extends => 'anyAtomicType' }; $builtin_types{normalizedString} = { parse => \&_replace , example => 'example' , extends => 'string' }; $builtin_types{language} = { parse => \&_collapse , check => sub { my $v = $_[0]; $v =~ s/\s+//g; $v =~ m/^[a-zA-Z]{1,8}(?:\-[a-zA-Z0-9]{1,8})*$/ } , example => 'nl-NL' , extends => 'token' }; # NCName matches pattern [\i-[:]][\c-[:]]* sub _ncname($) { (my $name = $_[0]) =~ s/\s//; $name =~ m/^[[:alpha:]_](?:[\w.-]*)$/; } my $ids = 0; $builtin_types{ID} = { parse => \&_collapse , check => \&_ncname , example => 'id_'.$ids++ , extends => 'NCName' }; $builtin_types{IDREF} = { parse => \&_collapse , check => \&_ncname , example => 'id-ref' , extends => 'NCName' }; $builtin_types{NCName} = { parse => \&_collapse , check => \&_ncname , example => 'label' , extends => 'Name' }; $builtin_types{ENTITY} = { parse => \&_collapse , check => \&_ncname , example => 'entity' , extends => 'NCName' }; $builtin_types{IDREFS} = $builtin_types{ENTITIES} = { parse => sub { [ split ' ', shift ] } , format => sub { my $v = shift; ref $v eq 'ARRAY' ? join(' ',@$v) : $v } , check => sub { $_[0] !~ m/\:/ } , example => 'labels' , is_list => 1 , extends => 'anySimpleType' }; $builtin_types{Name} = { parse => \&_collapse , example => 'name' , extends => 'token' }; $builtin_types{token} = { parse => \&_collapse , example => 'token' , extends => 'normalizedString' }; # check required! \c $builtin_types{NMTOKEN} = { parse => sub { $_[0] =~ s/\s+//g; $_[0] } , example => 'nmtoken' , extends => 'token' }; $builtin_types{NMTOKENS} = { parse => sub { [ split ' ', shift ] } , check => sub { $_[0] =~ /\S/ } , format => sub { my $v = shift; ref $v eq 'ARRAY' ? join(' ',@$v) : $v } , example => 'nmtokens' , is_list => 1 , extends => 'anySimpleType' }; # relative uri's are also correct, so even empty strings... it # cannot be checked without context. # use Regexp::Common qw/URI/; # check => sub { $_[0] =~ $RE{URI} } $builtin_types{anyURI} = { parse => \&_collapse , example => 'http://example.com' , extends => 'anyAtomicType' }; $builtin_types{QName} = { parse => sub { my ($qname, $node) = @_; $qname =~ s/\s//g; my $prefix = $qname =~ s/^([^:]*)\:// ? $1 : ''; $node = $node->node if $node->isa('XML::Compile::Iterator'); my $ns = $node->lookupNamespaceURI($prefix) || ''; pack_type $ns, $qname; } , format => sub { my ($type, $trans) = @_; my ($ns, $local) = unpack_type $type; length $ns or return $local; my $def = $trans->{$ns}; # let's hope that the namespace will get used somewhere else as # well, to make it into the xmlns. defined $def && exists $def->{used} or error __x"QName formatting only works if the namespace is used for an element, not found {ns} for {local}", ns => $ns, local => $local; length $def->{prefix} ? "$def->{prefix}:$local" : $local; } , example => 'myns:local' , extends => 'anyAtomicType' }; $builtin_types{NOTATION} = { extends => 'anyAtomicType' }; #------------- $builtin_types{binary} = { example => 'binary string' }; $builtin_types{timeDuration} = $builtin_types{duration}; $builtin_types{uriReference} = $builtin_types{anyURI}; # These constants where removed from the spec in 2001. Probably # no-one is using these (anymore) # century = period => 'P100Y' # recurringDate = duration => 'P24H', period => 'P1Y' # recurringDay = duration => 'P24H', period => 'P1M' # timeInstant = duration => 'P0Y', period => 'P0Y' # timePeriod = duration => 'P0Y' # year = period => 'P1Y' # recurringDuration = ?? # only in 2000/10 schemas $builtin_types{CDATA} = { parse => \&_replace , example => 'CDATA' }; 1; XML-Compile-1.64/lib/XML/Compile/Schema/NameSpaces.pm0000644000175000001440000001571114705455267022607 0ustar00markovusers00000000000000# Copyrights 2006-2024 by [Mark Overmeer ]. # For other contributors see ChangeLog. # See the manual pages for details on the licensing terms. # Pod stripped from pm file by OODoc 2.03. # This code is part of distribution XML-Compile. Meta-POD processed with # OODoc into POD and HTML manual-pages. See README.md # Copyright Mark Overmeer. Licensed under the same terms as Perl itself. package XML::Compile::Schema::NameSpaces;{ our $VERSION = '1.64'; } use warnings; use strict; use Log::Report 'xml-compile'; use XML::Compile::Util qw/pack_type unpack_type pack_id unpack_id SCHEMA2001/; use XML::Compile::Schema::BuiltInTypes qw/%builtin_types/; sub new($@) { my $class = shift; (bless {}, $class)->init( {@_} ); } sub init($) { my ($self, $args) = @_; $self->{tns} = {}; $self->{sgs} = {}; $self->{use} = []; $self; } sub list() { keys %{shift->{tns}} } sub namespace($) { my $nss = $_[0]->{tns}{$_[1]}; $nss ? @$nss : (); } sub add(@) { my $self = shift; foreach my $instance (@_) { # With the "new" targetNamespace attribute on any attribute, one # schema may have contribute to multiple tns's. Also, I have # encounted schema's without elements, but my @tnses = $instance->tnses; @tnses or @tnses = '(none)'; # newest definitions overrule earlier. unshift @{$self->{tns}{$_}}, $instance for @tnses; # inventory where to find definitions which belong to some # substitutionGroup. while(my($base,$ext) = each %{$instance->sgs}) { $self->{sgs}{$base}{$_} ||= $instance for @$ext; } } @_; } sub use($) { my $self = shift; push @{$self->{use}}, @_; @{$self->{use}}; } sub schemas($) { $_[0]->namespace($_[1]) } sub allSchemas() { my $self = shift; map {$self->schemas($_)} $self->list; } sub find($$;$) { my ($self, $kind) = (shift, shift); my ($ns, $name) = (@_%2==1) ? (unpack_type shift) : (shift, shift); my %opts = @_; defined $ns or return undef; my $label = pack_type $ns, $name; # re-pack unpacked for consistency foreach my $schema ($self->schemas($ns)) { my $def = $schema->find($kind, $label); return $def if defined $def; } my $used = exists $opts{include_used} ? $opts{include_used} : 1; $used or return undef; foreach my $use ( @{$self->{use}} ) { my $def = $use->namespaces->find($kind, $label, include_used => 0); return $def if defined $def; } undef; } sub doesExtend($$) { my ($self, $ext, $base) = @_; return 1 if $ext eq $base; return 0 if $ext =~ m/^unnamed /; my ($node, $super, $subnode); if(my $st = $self->find(simpleType => $ext)) { # pure simple type $node = $st->{node}; if(($subnode) = $node->getChildrenByLocalName('restriction')) { $super = $subnode->getAttribute('base'); } # list an union currently ignored } elsif(my $ct = $self->find(complexType => $ext)) { $node = $ct->{node}; # getChildrenByLocalName returns list, we know size one if(my($sc) = $node->getChildrenByLocalName('simpleContent')) { # tagged if(($subnode) = $sc->getChildrenByLocalName('extension')) { $super = $subnode->getAttribute('base'); } elsif(($subnode) = $sc->getChildrenByLocalName('restriction')) { $super = $subnode->getAttribute('base'); } } elsif(my($cc) = $node->getChildrenByLocalName('complexContent')) { # real complex if(($subnode) = $cc->getChildrenByLocalName('extension')) { $super = $subnode->getAttribute('base'); } elsif(($subnode) = $cc->getChildrenByLocalName('restriction')) { $super = $subnode->getAttribute('base'); } } } else { # built-in my ($ns, $local) = unpack_type $ext; $ns eq SCHEMA2001 && $builtin_types{$local} or error __x"cannot find {type} as simpleType or complexType" , type => $ext; my ($bns, $blocal) = unpack_type $base; $ns eq $bns or return 0; while(my $e = $builtin_types{$local}{extends}) { return 1 if $e eq $blocal; $local = $e; } } $super or return 0; my ($prefix, $local) = $super =~ m/:/ ? split(/:/,$super,2) : ('',$super); my $supertype = pack_type $subnode->lookupNamespaceURI($prefix), $local; $base eq $supertype ? 1 : $self->doesExtend($supertype, $base); } sub findTypeExtensions($) { my ($self, $type) = @_; my %ext; if($self->find(simpleType => $type)) { $self->doesExtend($_, $type) && $ext{$_}++ for map $_->simpleTypes, $self->allSchemas; } elsif($self->find(complexType => $type)) { $self->doesExtend($_, $type) && $ext{$_}++ for map $_->complexTypes, $self->allSchemas; } else { error __x"cannot find base-type {type} for extensions", type => $type; } sort keys %ext; } sub autoexpand_xsi_type($) { my ($self, $type) = @_; my @ext = $self->findTypeExtensions($type); trace "discovered xsi:type choices for $type:\n ". join("\n ", @ext); \@ext; } sub findSgMembers($$) { my ($self, $class, $base) = @_; my $s = $self->{sgs}{$base} or return; my @sgs; while(my($ext, $instance) = each %$s) { push @sgs, $instance->find($class => $ext) , $self->findSgMembers($class, $ext); } @sgs; } sub findID($;$) { my $self = shift; my ($label, $ns, $id) = @_==1 ? ($_[0], unpack_id $_[0]) : (pack_id($_[0], $_[1]), @_); defined $ns or return undef; my $xpc = XML::LibXML::XPathContext->new; $xpc->registerNs(a => $ns); my @nodes; foreach my $fragment ($self->schemas($ns)) { @nodes = $xpc->findnodes("/*/a:*#$id", $fragment->schema) or next; return $nodes[0] if @nodes==1; error "multiple elements with the same id {id} in {source}" , id => $label , source => ($fragment->filename || $fragment->source); } undef; } sub printIndex(@) { my $self = shift; my $fh = @_ % 2 ? shift : select; my %opts = @_; my $nss = delete $opts{namespace} || [$self->list]; foreach my $nsuri (ref $nss eq 'ARRAY' ? @$nss : $nss) { $_->printIndex($fh, %opts) for $self->namespace($nsuri); } my $show_used = exists $opts{include_used} ? $opts{include_used} : 1; foreach my $use ($self->use) { $use->printIndex(%opts, include_used => 0); } $self; } sub importIndex(%) { my ($self, %args) = @_; my %import; foreach my $fragment (map $self->schemas($_), $self->list) { foreach my $import ($fragment->imports) { $import{$import}{$_}++ for $fragment->importLocations($import); } } foreach my $ns (keys %import) { $import{$ns} = [ grep length, keys %{$import{$ns}} ]; } \%import; } 1; XML-Compile-1.64/lib/XML/Compile/Schema/BuiltInTypes.pod0000644000175000001440000002226614705455304023324 0ustar00markovusers00000000000000=encoding utf8 =head1 NAME XML::Compile::Schema::BuiltInTypes - Define handling of built-in data-types =head1 INHERITANCE XML::Compile::Schema::BuiltInTypes is an Exporter =head1 SYNOPSIS # Not for end-users use XML::Compile::Schema::BuiltInTypes qw/%builtin_types/; =head1 DESCRIPTION Different schema specifications specify different available types, but there is a lot over overlap. The L module defines the availability, but here the types are implemented. This implementation certainly does not try to be minimal in size: following the letter of the restriction rules and inheritance structure defined by the W3C schema specification would be too slow. =head1 FUNCTIONS =head2 Real functions =over 4 =item B($type) Returns the configuration for $type, which is a HASH. Be aware that the information in this HASH will change over time without too much notice. Implement regression-tests in this if you use it! =back =head2 The Types The functions named in this section are all used at compile-time by the translator. At that moment, they will be placed in the kind-of opcode tree which will process the data at run-time. You B these functions yourself. XML::Compile will automatically format the value for you. For instance, a float supplied to a field defined as type Integer will be converted to an integer. Data supplied to a field of type base64Binary will be encoded as Base64 for you: you shouldn't do the conversion yourself, you'll get double encoding! =head3 Any =over 4 =item B() =item B() =item B() Both any*Type built-ins can contain any kind of data. Perl decides how to represent the passed values. =item B() =back =head3 Ungrouped types =over 4 =item B() Contains C, C, C<1> (is true), or C<0> (is false). When the writer sees a value equal to 'true' or 'false', those are used. Otherwise, the trueth value is evaluated into '0' or '1'. The reader will return '0' (also when the XML contains the string 'false', to simplify the Perl code) or '1'. =item B() =back =head3 Big Integers Schema's define integer types which are derived from the C type. These values can grow enormously large, and therefore can only be handled correctly using Math::BigInt. When the translator is built with the C option, this will simplify (speed-up) the produced code considerably: all integers then shall be between -2G and +2G. =over 4 =item B() An integer with an undertermined (but possibly large) number of digits. =item B() A little bit shorter than an integer, but still up-to 19 digits. =item B() =item B() =item B() =item B() =item B() Just too long to fit in Perl's ints. =item B() Value up-to 20 digits. =back =head3 Integers =over 4 =item B() Signed 8-bits value. =item B() =item B() Signed 16-bits value. =item B() Unsigned 8-bits value. =item B() unsigned 16-bits value. =back =head3 Floating-point =over 4 =item B() Decimals are painful: they can be very large, much larger than Perl's internal floats. Therefore, we need to use Math::BigFloat which are slow but nearly seamlessly invisible in the application. =item B() A floating-point value "m x 2**e", where m is an integer whose absolute value is less than 253, and e is an integer between −1074 and 971, inclusive. The implementation does not limited the double in size, but maps it onto an precisionDecimal (Math::BigFloat) unless C is set. =item B() A small floating-point value "m x 2**e" where m is an integer whose absolute value is less than 224, and e is an integer between −149 and 104, inclusive. The implementation does not limited the float in size, but maps it onto an precisionDecimal (Math::BigFloat) unless C is set. =item B() Floating point value that closely corresponds to the floating-point decimal datatypes described by IEEE/ANSI-754. =back =head3 Encoding =over 4 =item B() In the hash, it will be kept as binary data. In XML, it will be base64 encoded. =item B() In the hash, it will be kept as binary data. In XML, it will be hex encoded, two hex digits per byte. =back =head3 Dates =over 4 =item B() A day, represented in localtime as C or C. When a decimal value is passed, it is interpreted as C