XML-Compile-1.58/0000755000175000001440000000000013124470325014214 5ustar00markovusers00000000000000XML-Compile-1.58/t/0000755000175000001440000000000013124470325014457 5ustar00markovusers00000000000000XML-Compile-1.58/t/92json.t0000644000175000001440000001736313120230254015771 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; $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.58/t/34abstract.t0000644000175000001440000000236013120230254016606 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.58/t/58default.t0000644000175000001440000001245113120230254016437 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.58/t/73rewrite.t0000644000175000001440000000672313120230254016476 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.58/t/47ctsres.t0000644000175000001440000000372113120230254016314 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.58/t/77form.t0000644000175000001440000000324113120230254015754 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.58/t/44stres.t0000644000175000001440000000413413120230254016145 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.58/t/76blocked.t0000644000175000001440000001112613120230254016414 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.58/t/81-2000.t0000644000175000001440000000110513120230254015437 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.58/t/75type.t0000644000175000001440000000570213120230254015774 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.58/t/TestTools.pm0000644000175000001440000000507613124470276016772 0ustar00markovusers00000000000000# Copyrights 2006-2017 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.02. use warnings; use strict; package TestTools; use vars '$VERSION'; $VERSION = '1.58'; 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.58/t/61hooks_w.t0000644000175000001440000000466013120230254016461 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.58/t/40seq.t0000644000175000001440000002706113120230254015575 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.58/t/57fixed.t0000644000175000001440000000436113120230254016112 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.58/t/33ref.t0000644000175000001440000000436213120230254015562 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 => 25; 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 XML-Compile-1.58/t/45ctcres.t0000644000175000001440000000217413120230254016273 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.58/t/52anytype.t0000644000175000001440000000237713120230254016504 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.58/t/31elem.t0000644000175000001440000000432613120230254015726 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.58/t/59big.t0000644000175000001440000000530413120230254015554 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.58/t/30compile.t0000644000175000001440000000414213120230254016427 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.58/t/54nil.t0000644000175000001440000002134713120230254015575 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.58/t/45ctcext.t0000644000175000001440000000615413120230254016304 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.58/t/01use.t0000644000175000001440000000364313120230254015576 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.58/t/50union.t0000644000175000001440000000475513120230254016143 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 => 91; 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, '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'); XML-Compile-1.58/t/70templ.t0000644000175000001440000001563413120230254016134 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.58/t/90nons.t0000644000175000001440000000311513120230254015761 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.58/t/63mixed.t0000644000175000001440000000707513120230254016123 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.58/t/39ns.t0000644000175000001440000000706013120230254015432 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.58/t/74qname.t0000644000175000001440000000367113120230254016116 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.58/t/62recurse.t0000644000175000001440000000466313120230254016464 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.58/t/41choice.t0000644000175000001440000002040713120230254016235 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.58/t/56pats.t0000644000175000001440000000172413120230254015761 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.58/t/22call.t0000644000175000001440000000222213120230254015710 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.58/t/55facet_date.t0000644000175000001440000000203413120230254017063 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.58/t/55facet_dura.t0000644000175000001440000000232613120230254017105 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.58/t/60hooks_r.t0000644000175000001440000000741413120230254016453 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.58/t/02ext.t0000644000175000001440000000420213120230254015573 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.58/t/48subst.t0000644000175000001440000001001213124470276016157 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 => 57; 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 ### multi-level $schema->importDefinitions( <<__EXTRA ); __EXTRA my %t6 = (head => [ {alt3 => 61} ], id2 => 62); test_rw($schema, test2 => <<__XML, \%t6); 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.58/t/91noqual.t0000644000175000001440000000370413120230254016310 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.58/t/51any.t0000644000175000001440000001634713120230254015603 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.58/t/42all.t0000644000175000001440000001174413120230254015560 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.58/t/03duration.t0000644000175000001440000000372213120230254016627 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.58/t/49list.t0000644000175000001440000000443613120230254015772 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 => 92; 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, [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, [4, 5, 6]); 4 5\t 6 __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.58/t/55facet.t0000644000175000001440000003044113120230254016071 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.58/t/46ctsext.t0000644000175000001440000000302513120230254016317 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.58/t/64xsi.t0000644000175000001440000000162313120230254015612 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.58/t/32attr.t0000644000175000001440000000736013120230254015760 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.58/t/20spec.t0000644000175000001440000000353413120230254015734 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.58/t/43group.t0000644000175000001440000000230413120230254016135 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 => 17; set_compile_defaults elements_qualified => 'NONE'; my $schema = XML::Compile::Schema->new( <<__SCHEMA__ ); __SCHEMA__ ok(defined $schema); my $error; test_rw($schema, test1 => <<__XML, {g1_a => 10, g1_b => 11}); 1011 __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 XML-Compile-1.58/t/21types.t0000644000175000001440000000651413120230254016150 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.58/t/72typemap.t0000644000175000001440000001303113120230254016461 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.58/t/55facet_list.t0000644000175000001440000000512113120230254017121 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_DOTTED_VERSION(); $xml2_version lt '2.7' 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.58/bin/0000755000175000001440000000000013124470325014764 5ustar00markovusers00000000000000XML-Compile-1.58/bin/schema2example0000644000175000001440000000702713120230254017602 0ustar00markovusers00000000000000#!/home/satfoto/bin/perl use warnings; use strict; use XML::Compile::Schema (); use XML::Compile::Util qw/type_of_node/; use Getopt::Long qw/GetOptions :config gnu_compat bundling/; my ($xml_input, $root_type, @schemas, $outfile); my $format = 'PERL'; my $show = 'ALL'; GetOptions 'format|f=s' => \$format , "output|o=s" => \$outfile , "schema|s=s" => \@schemas , "show=s" => \$show , "type|t=s" => \$root_type , "xml|x=s" => \$xml_input; $xml_input = '-' if @schemas && !defined $xml_input; if(@ARGV) { die "ERROR: either use options or no options, not mixed\n" if defined $xml_input && @ARGV; ($xml_input, @schemas) = @ARGV; } defined $xml_input or die "ERROR: no input message specified\n"; @schemas or die "ERROR: no schema's specified\n"; @schemas = map { split /\,/ } @schemas; $format = uc $format; die "ERROR: format must be either 'PERL' or 'XML'\n" if $format ne 'PERL' && $format ne 'XML'; my $parser = XML::LibXML->new; my $msg = $xml_input eq '-' ? $parser->parse_fh(\*STDIN) : $parser->parse_file($xml_input); my $top = $msg->documentElement; $root_type ||= type_of_node $top; my $schema = XML::Compile::Schema->new; $schema->importDefinitions($_) for @schemas; my $output = $schema->template ( $format , $root_type , show => $show ); if($outfile) { open OUT, ">:utf8", $outfile or die "ERROR: cannot write yaml to $outfile: $!\n"; print OUT $output; close OUT or die "ERROR: write error for $outfile: $!\n"; } else { print $output; } exit 0; __END__ =head1 NAME schema2example - convert XML schema knowledge into Perl or XML examples =head1 SYNOPSIS schema2example xml-file schema-file(s) >outfile schema2example -x xml-file -s schema-file(s) -o outfile =head1 DESCRIPTION XML schemas are quite hard to read, certainly when multiple name-spaces are involved. The template() function in XML::Compile::Schema function can help displaying the expected structure of a message; this module is a wrapper around that function. =head2 Options You can either specify an XML message filename and one or more schema filenames as arguments, or use the options. =over 4 =item --xml|-x filename The file which contains the xml message. A single dash means "stdin". =item --schema|-s filename(s) This option can be repeated, or the filenames separated by comma's, if you have more than one schema file to parse. All imported and included schema components have to be provided explicitly. =item --type|-t TYPE The type of the root element, required if the XML is not namespaceo qualified, although the schema is. If not specified, the root element is automatically inspected. The TYPE notation is C<{namespace}localname>. Be warned to use quoting on the UNIX command-line, because curly braces have a special meaning for the shell. =item --output|-o filename By default, the output is to stdout. =item --show STRING A comma separated list of comment components which should be included, by default C. An empty string or C will exclude all comments. The STRING can also be a comma separated combination of C, C, C, and C. =back =head1 SEE ALSO This module is part of Perl's XML-Compile distribution. Website: F =head1 LICENSE Copyrights 2008 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.58/bin/xml2yaml0000644000175000001440000000772313120230254016454 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use XML::Compile::Schema (); use XML::Compile::Util qw/type_of_node/; use Getopt::Long qw/GetOptions :config gnu_compat bundling/; use YAML qw/Dump/; my ($xml_input, $root_type, @schemas, $bigints, $bigfloats, $yaml_out); my $mixed = 'TEXTUAL'; my $keep_root = 1; GetOptions 'bigints|bi|b!' => \$bigints , 'bigfloats|bf' => \$bigfloats , 'keep-root|r!' => \$keep_root , 'output|o=s' => \$yaml_out , 'schema|s=s' => \@schemas , 'type|t=s' => \$root_type , 'xml|x=s' => \$xml_input , 'mixed=s' => \$mixed or exit 1; $xml_input = '-' if @schemas && !defined $xml_input; $yaml_out = '-' unless defined $yaml_out; if(@ARGV) { die "ERROR: either use options or no options, not mixed\n" if defined $xml_input && @ARGV; ($xml_input, @schemas) = @ARGV; } defined $xml_input or die "ERROR: no input message specified\n"; @schemas or die "ERROR: no schema's specified\n"; @schemas = map { split /\,/ } @schemas; my $parser = XML::LibXML->new; my $msg = $xml_input eq '-' ? $parser->parse_fh(\*STDIN) : $parser->parse_file($xml_input); my $top = $msg->documentElement; $root_type ||= type_of_node $top; my $schema = XML::Compile::Schema->new( \@schemas ); my $read = $schema->compile ( READER => $root_type , sloppy_integers => !$bigints , sloppy_floats => !$bigfloats , mixed_elements => $mixed ); my $ast = $read->($top); $ast = { $top->localname => $ast } if $keep_root; my $data = Dump $ast; if($yaml_out eq '-') { print $data; } else { open OUT, ">:utf8", $yaml_out or die "ERROR: cannot write yaml to $yaml_out: $!\n"; print OUT $data; close OUT or die "ERROR: write error for $yaml_out: $!\n"; } exit 0; __END__ =head1 NAME xml2yaml - convert an XML message with a schema into YAML =head1 SYNOPSIS xml2yaml xml-file schema-file(s) >yaml-file xml2yaml -x xml-file -s schema-files -o yaml-file =head1 DESCRIPTION Convert an XML message into YAML with the same structure. A schema is required to enforce the correct syntax, especially for optionally repeated elements. =head2 Options You can either specify an XML message filename and one or more schema filenames as arguments, or use the options. =over 4 =item --xml|-x filename The file which contains the xml message. A single dash means "stdin". =item --schema|-s filename(s) This option can be repeated, or the filenames separated by comma's, if you have more than one schema file to parse. All imported and included schema components have to be provided explicitly. =item --bigints|-b (boolean) By default, the translation is a little sloppy: Integer types are defined to support at least 18 digits in XML. However, this is usually unnecessary large and unreadible in YAML. =item --no-keep-root (boolean) Do not include the top node in the output. =item --mixed HOW [1.32] How to treat mixed elements. The default is TEXTUAL. Other values are C, C, and C. More details about mixed_elements in XML::Compile::Translate::Reader. =item --type|-t TYPE The type of the root element, required if the XML is not namespaceo qualified, although the schema is. If not specified, the root element is automatically inspected. The TYPE notation is C<{namespace}localname>. Be warned to use quoting on the UNIX command-line, because curly braces have a special meaning for the shell. =item --output|-o filename By default (or when the filename is a dash), the output is printed to stdout. =back =head1 SEE ALSO This module is part of Perl's XML-Compile distribution. Website: F =head1 LICENSE Copyrights 2008 by Slaven Rezic and 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.58/bin/xml2json0000644000175000001440000000776013120230254016464 0ustar00markovusers00000000000000#!/usr/bin/env perl use warnings; use strict; use XML::Compile::Schema (); use XML::Compile::Util qw/type_of_node/; use Getopt::Long qw/GetOptions :config gnu_compat bundling/; use JSON::XS qw/encode_json/; my ($xml_input, $root_type, @schemas, $bigints, $bigfloats, $json_out); my $mixed = 'TEXTUAL'; my $keep_root = 1; GetOptions 'bigints|bi|b!' => \$bigints , 'bigfloats|bf' => \$bigfloats , 'output|o=s' => \$json_out , 'schema|s=s' => \@schemas , 'type|t=s' => \$root_type , 'xml|x=s' => \$xml_input , 'mixed=s' => \$mixed , 'keep-root|r!' => \$keep_root or exit 1; $xml_input = '-' if @schemas && !defined $xml_input; $json_out = '-' unless defined $json_out; if(@ARGV) { die "ERROR: either use options or no options, not mixed\n" if defined $xml_input && @ARGV; ($xml_input, @schemas) = @ARGV; } defined $xml_input or die "ERROR: no input message specified\n"; @schemas or die "ERROR: no schema's specified\n"; @schemas = map { split /\,/ } @schemas; my $parser = XML::LibXML->new; my $msg = $xml_input eq '-' ? $parser->parse_fh(\*STDIN) : $parser->parse_file($xml_input); my $top = $msg->documentElement; $root_type ||= type_of_node $top; my $schema = XML::Compile::Schema->new( \@schemas ); my $read = $schema->compile ( READER => $root_type , sloppy_integers => !$bigints , sloppy_floats => !$bigfloats , json_friendly => 1 , mixed_elements => $mixed ); my $ast = $read->($top); $ast = { $top->localname => $ast } if $keep_root; my $data = encode_json $ast; if($json_out eq '-') { print $data; } else { open OUT, ">:utf8", $json_out or die "ERROR: cannot write json to $json_out: $!\n"; print OUT $data; close OUT or die "ERROR: write error for $json_out: $!\n"; } exit 0; __END__ =head1 NAME xml2json - convert an XML message with a schema into JSON =head1 SYNOPSIS xml2json xml-file schema-file(s) >json-file xml2json -x xml-file -s schema-files -o json-file =head1 DESCRIPTION Convert an XML message into JSON with the same structure. A schema is required to enforce the correct syntax, especially for optionally repeated elements. =head2 Options You can either specify an XML message filename and one or more schema filenames as arguments, or use the options. =over 4 =item --xml|-x filename The file which contains the xml message. A single dash means "stdin". =item --schema|-s filename(s) This option can be repeated, or the filenames separated by comma's, if you have more than one schema file to parse. All imported and included schema components have to be provided explicitly. =item --bigints|-b (boolean) By default, the translation is a little sloppy: Integer types are defined to support at least 18 digits in XML. However, this is usually unnecessary large and unreadible in JSON. =item --no-keep-root (boolean) Do not include the top node in the output. =item --mixed HOW [1.32] How to treat mixed elements. The default is TEXTUAL. Other values are C, C, and C. More details about mixed_elements in XML::Compile::Translate::Reader. =item --type|-t TYPE The type of the root element, required if the XML is not namespaceo qualified, although the schema is. If not specified, the root element is automatically inspected. The TYPE notation is C<{namespace}localname>. Be warned to use quoting on the UNIX command-line, because curly braces have a special meaning for the shell. =item --output|-o filename By default (or when the filename is a dash), the output is printed to stdout. =back =head1 SEE ALSO This module is part of Perl's XML-Compile distribution. Website: F =head1 LICENSE Copyrights 2017 by Slaven Rezic and 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.58/MANIFEST0000644000175000001440000000477113124470325015356 0ustar00markovusers00000000000000ChangeLog MANIFEST Makefile.PL README README.todo bin/schema2example bin/xml2json bin/xml2yaml html/manual/doclist.html html/manual/grouped.html html/manual/head.html html/manual/index.html html/manual/main.html html/manual/methods.html html/manual/relations.html html/manual/sorted.html html/other/details/index.html html/other/diagnostics/index.html html/other/index.html html/other/jump.cgi html/other/manuals/head.html html/other/manuals/index.html html/other/manuals/list.html html/other/methods/index.html html/other/xml.css lib/XML/Compile.pm lib/XML/Compile.pod lib/XML/Compile/FAQ.pod lib/XML/Compile/Iterator.pm lib/XML/Compile/Iterator.pod lib/XML/Compile/Schema.pm lib/XML/Compile/Schema.pod lib/XML/Compile/Schema/BuiltInFacets.pm lib/XML/Compile/Schema/BuiltInFacets.pod lib/XML/Compile/Schema/BuiltInTypes.pm lib/XML/Compile/Schema/BuiltInTypes.pod lib/XML/Compile/Schema/Instance.pm lib/XML/Compile/Schema/Instance.pod lib/XML/Compile/Schema/NameSpaces.pm lib/XML/Compile/Schema/NameSpaces.pod lib/XML/Compile/Schema/Specs.pm lib/XML/Compile/Schema/Specs.pod lib/XML/Compile/Translate.pm lib/XML/Compile/Translate.pod lib/XML/Compile/Translate/Reader.pm lib/XML/Compile/Translate/Reader.pod lib/XML/Compile/Translate/Template.pm lib/XML/Compile/Translate/Template.pod lib/XML/Compile/Translate/Writer.pm lib/XML/Compile/Translate/Writer.pod lib/XML/Compile/Util.pm lib/XML/Compile/Util.pod lib/XML/Compile/xsd/1998-namespace.xsd lib/XML/Compile/xsd/1999-XMLSchema-part2.xsd lib/XML/Compile/xsd/1999-XMLSchema.xsd lib/XML/Compile/xsd/2000-XMLSchema.xsd lib/XML/Compile/xsd/2001-XMLSchema-instance.xsd lib/XML/Compile/xsd/2001-XMLSchema.dtd lib/XML/Compile/xsd/2001-XMLSchema.xsd lib/XML/Compile/xsd/2001-datatypes.dtd t/01use.t t/02ext.t t/03duration.t t/20spec.t t/21types.t t/22call.t t/30compile.t t/31elem.t t/32attr.t t/33ref.t t/34abstract.t t/39ns.t t/40seq.t t/41choice.t t/42all.t t/43group.t t/44stres.t t/45ctcext.t t/45ctcres.t t/46ctsext.t t/47ctsres.t t/48subst.t t/49list.t t/50union.t t/51any.t t/52anytype.t t/54nil.t t/55facet.t t/55facet_date.t t/55facet_dura.t t/55facet_list.t t/56pats.t t/57fixed.t t/58default.t t/59big.t t/60hooks_r.t t/61hooks_w.t t/62recurse.t t/63mixed.t t/64xsi.t t/70templ.t t/72typemap.t t/73rewrite.t t/74qname.t t/75type.t t/76blocked.t t/77form.t t/81-2000.t t/90nons.t t/91noqual.t t/92json.t t/TestTools.pm xt/99pod.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) XML-Compile-1.58/lib/0000755000175000001440000000000013124470325014762 5ustar00markovusers00000000000000XML-Compile-1.58/lib/XML/0000755000175000001440000000000013124470325015422 5ustar00markovusers00000000000000XML-Compile-1.58/lib/XML/Compile/0000755000175000001440000000000013124470325017012 5ustar00markovusers00000000000000XML-Compile-1.58/lib/XML/Compile/Schema/0000755000175000001440000000000013124470325020212 5ustar00markovusers00000000000000XML-Compile-1.58/lib/XML/Compile/Schema/Instance.pod0000644000175000001440000001020213124470314022453 0ustar00markovusers00000000000000=encoding utf8 =head1 NAME XML::Compile::Schema::Instance - Represents one schema =head1 SYNOPSIS # Used internally by XML::Compile::Schema my $schema = XML::Compile::Schema::Instance->new($xml); =head1 DESCRIPTION This module collect information from one schema, and helps to process it. =head1 METHODS =head2 Constructors =over 4 =item $obj-EB($top, %options) Get's the top of an XML::LibXML tree, which must be a schema element. The tree is parsed: the information collected. -Option --Default attribute_form_default element_form_default filename undef source undef target_namespace =over 2 =item attribute_form_default => 'qualified'|'unqualified' =item element_form_default => 'qualified'|'unqualified' Overrule the default as found in the schema. Many old schemas (like WSDL11 and SOAP11) do not specify the default in the schema but only in the text. =item filename => FILENAME When the source is some file, this is its name. =item source => STRING An indication where this information came from. =item target_namespace => NAMESPACE Overrule or set the target namespace. =back =back =head2 Accessors =over 4 =item $obj-EB() Returns a list of all defined attribute groups. =item $obj-EB() Returns a lost of all globally defined attribute names. =item $obj-EB() Returns a list with all complexType names. =item $obj-EB($uri) Returns one global element definition. =item $obj-EB() Returns a list of all globally defined element names. =item $obj-EB() =item $obj-EB() Returns a list of all defined model groups. =item $obj-EB() =item $obj-EB() =item $obj-EB() =item $obj-EB() Returns a HASH with the base-type as key and an ARRAY of types which extend it. =item $obj-EB() Returns a list with all simpleType names. =item $obj-EB() =item $obj-EB() =item $obj-EB() A schema can defined more than one target namespace, where recent schema spec changes provide a targetNamespace attribute. =item $obj-EB($uri) Returns the type definition with the specified name. =item $obj-EB() Returns a list of all simpleTypes and complexTypes =back =head2 Index =over 4 =item $obj-EB($kind, $fullname) Returns the definition for the object of $kind, with $fullname. example: of find my $attr = $instance->find(attribute => '{myns}my_global_attr'); =item $obj-EB($ns) Returns a list of all schemaLocations specified with the import $ns (one of the values returned by L). =item $obj-EB() Returns a list with all namespaces which need to be imported. =item $obj-EB() Returns a list of all schemaLocations which where specified with include statements. =item $obj-EB( [$fh], %options ) Prints an overview over the defined objects within this schema to the selected $fh. -Option --Default kinds list_abstract =over 2 =item kinds => KIND|ARRAY-of-KIND Which KIND of definitions would you like to see. Pick from C, C, C, C, C, and C. =item list_abstract => BOOLEAN Show abstract elements, or skip them (because they cannot be instantiated anyway). =back =back =head1 SEE ALSO This module is part of XML-Compile distribution version 1.58, built on June 27, 2017. Website: F Please post questions or ideas to the mailinglist at F . For live contact with other developers, visit the C<#xml-compile> channel on C. =head1 LICENSE Copyrights 2006-2017 by [Mark Overmeer]. For other contributors see ChangeLog. This program is free software; you can redistribute it and/or modify it under the Artistic license. See F XML-Compile-1.58/lib/XML/Compile/Schema/BuiltInFacets.pod0000644000175000001440000000230013124470313023402 0ustar00markovusers00000000000000=encoding utf8 =head1 NAME XML::Compile::Schema::BuiltInFacets - handling of built-in facet checks =head1 INHERITANCE XML::Compile::Schema::BuiltInFacets is a 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.58, built on June 27, 2017. Website: F Please post questions or ideas to the mailinglist at F . For live contact with other developers, visit the C<#xml-compile> channel on C. =head1 LICENSE Copyrights 2006-2017 by [Mark Overmeer]. For other contributors see ChangeLog. This program is free software; you can redistribute it and/or modify it under the Artistic license. See F XML-Compile-1.58/lib/XML/Compile/Schema/BuiltInTypes.pm0000644000175000001440000004052713124470276023160 0ustar00markovusers00000000000000# Copyrights 2006-2017 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.02. use warnings; use strict; no warnings 'recursion'; package XML::Compile::Schema::BuiltInTypes; use vars '$VERSION'; $VERSION = '1.58'; use base 'Exporter'; our @EXPORT = qw/%builtin_types builtin_type_info/; our %builtin_types; use Log::Report 'xml-compile', syntax => 'SHORT'; 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/^[a-zA-Z_](?:[\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.58/lib/XML/Compile/Schema/NameSpaces.pod0000644000175000001440000001131413124470314022733 0ustar00markovusers00000000000000=encoding utf8 =head1 NAME XML::Compile::Schema::NameSpaces - Connect name-spaces from schemas =head1 SYNOPSIS # Used internally by XML::Compile::Schema my $nss = XML::Compile::Schema::NameSpaces->new; $nss->add($schema); =head1 DESCRIPTION This module keeps overview on a set of namespaces, collected from various schema files. Per XML namespace, it will collect a list of fragments which contain definitions for the namespace, each fragment comes from a different source. These fragments are searched in reverse order when an element or type is looked up (the last definitions overrule the older definitions). =head1 METHODS =head2 Constructors =over 4 =item $obj-EB(%options) =back =head2 Accessors =over 4 =item $obj-EB( $schema, [$schemas] ) Add L objects to the internal knowledge of this object. =item $obj-EB() Returns a list of all known schema instances. =item $obj-EB($exttype, $basetype) Returns true when $exttype extends $basetype. =item $obj-EB($kind, $address|<$uri,$name>, %options) Lookup the definition for the specified $kind of definition: the name of a global element, global attribute, attributeGroup or model group. The $address is constructed as C< {uri}name > or as separate $uri and $name. -Option --Default include_used =over 2 =item include_used => BOOLEAN =back =item $obj-EB( $address|<$uri,$id> ) Lookup the definition for the specified id, which is constructed as C< uri#id > or as separate $uri and $id. =item $obj-EB($class, $type) Lookup the substitutionGroup alternatives for a specific element, which is an $type (element full name) of form C< {uri}name > or as separate URI and NAME. Returned is an ARRAY of HASHes, each describing one type (as returned by L) =item $obj-EB($type) This method can be quite expensive, with large and nested schemas. =item $obj-EB(%options) [1.41] Returns a HASH with namespaces which are declared in all currently known schema's, pointing to ARRAYs of the locations where the import should come from. In reality, the locations mentioned are often wrong. But when you think you want to load all schema's dynamically at start-up (no, you do not want it but it is a SOAP paradigma) then you get that info easily with this method. =item $obj-EB() Returns the list of name-space URIs defined. =item $obj-EB($uri) Returns a list of L objects which have the $uri as target namespace. =item $obj-EB( [$fh], %options ) Show all definitions from all namespaces, for debugging purposes, by default the selected. Additional %options are passed to L. -Option --Default include_used namespace =over 2 =item include_used => BOOLEAN Show also the index from all the schema objects which are defined to be usable as well; which were included via L. =item namespace => URI|ARRAY-of-URI Show only information about the indicate namespaces. =back example: my $nss = $schema->namespaces; $nss->printIndex(\*MYFILE); $nss->printIndex(namespace => "my namespace"); # types defined in the wsdl schema use XML::Compile::SOAP::Util qw/WSDL11/; $nss->printIndex(\*STDERR, namespace => WSDL11); =item $obj-EB($uri) We need the name-space; when it is lacking then import must help, but that must be called explicitly. =item $obj-EB($object) Use any other L extension as fallback, if the L does not succeed for the current object. Searches for definitions do not recurse into the used object. Returns the list of all used OBJECTS. This method implements L. =back =head1 SEE ALSO This module is part of XML-Compile distribution version 1.58, built on June 27, 2017. Website: F Please post questions or ideas to the mailinglist at F . For live contact with other developers, visit the C<#xml-compile> channel on C. =head1 LICENSE Copyrights 2006-2017 by [Mark Overmeer]. For other contributors see ChangeLog. This program is free software; you can redistribute it and/or modify it under the Artistic license. See F XML-Compile-1.58/lib/XML/Compile/Schema/Specs.pod0000644000175000001440000000441413124470314021774 0ustar00markovusers00000000000000=encoding utf8 =head1 NAME XML::Compile::Schema::Specs - Predefined Schema Information =head1 SYNOPSIS # not for end-users use XML::Compile::Schema::Specs; =head1 DESCRIPTION This package defines the various schema-specifications. =head1 METHODS =over 4 =item XML::Compile::Schema::Specs-EB( <$node|undef>, $expanded | <$uri,$local>, %options ) Provide an $expanded (full) type name or an namespace $uri and a $local node name. Returned is a HASH with process information or C if not found. -Option --Default json_friendly sloppy_floats sloppy_integers =over 2 =item json_friendly => BOOLEAN The READER is slightly different, to produce output which can be passed on to JSON serializers without need for conversion. Implies C. =item sloppy_floats => BOOLEAN The float types of XML are all quite big, and support NaN, INF, and -INF. Perl's normal floats do not, and therefore Math::BigFloat is used. This, however, is slow. When true, your application will crash on any value which is not understood by Perl's default float... but run much faster. =item sloppy_integers => BOOLEAN the types must accept huge integers, which require C objects to process. But often, Perl's normal signed 32bit integers suffice... which is good for performance, but not standard compliant. =back =item XML::Compile::Schema::Specs-EB($uri) Return a HASH which contains the schema information for the specified $uri (or undef if it doesn't exist). =item XML::Compile::Schema::Specs-EB() Returns the uri of all predefined schemas. =back =head1 SEE ALSO This module is part of XML-Compile distribution version 1.58, built on June 27, 2017. Website: F Please post questions or ideas to the mailinglist at F . For live contact with other developers, visit the C<#xml-compile> channel on C. =head1 LICENSE Copyrights 2006-2017 by [Mark Overmeer]. For other contributors see ChangeLog. This program is free software; you can redistribute it and/or modify it under the Artistic license. See F XML-Compile-1.58/lib/XML/Compile/Schema/BuiltInFacets.pm0000644000175000001440000003053313124470276023255 0ustar00markovusers00000000000000# Copyrights 2006-2017 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.02. use warnings; use strict; no warnings 'recursion'; package XML::Compile::Schema::BuiltInFacets; use vars '$VERSION'; $VERSION = '1.58'; use base 'Exporter'; our @EXPORT = qw/builtin_facet/; use Log::Report 'xml-compile', syntax => 'SHORT'; use Math::BigInt; use Math::BigFloat; use XML::LibXML; # for ::RegExp use XML::Compile::Util qw/SCHEMA2001 pack_type duration2secs/; use POSIX qw/DBL_MAX_10_EXP DBL_DIG/; # depend on Perl's compile flags use constant INT_MAX => int((sprintf"%u\n",-1)/2); use constant INT_MIN => -1 - INT_MAX; my %facets_simple = ( enumeration => \&_enumeration , fractionDigits => \&_s_fractionDigits , length => \&_s_length , maxExclusive => \&_s_maxExclusive , maxInclusive => \&_s_maxInclusive , maxLength => \&_s_maxLength , maxScale => undef # ignore , minExclusive => \&_s_minExclusive , minInclusive => \&_s_minInclusive , minLength => \&_s_minLength , minScale => undef # ignore , pattern => \&_pattern , totalDigits => \&_s_totalDigits , whiteSpace => \&_s_whiteSpace , _totalFracDigits=> \&_s_totalFracDigits ); my %facets_list = ( enumeration => \&_enumeration , length => \&_list_length , maxLength => \&_list_maxLength , minLength => \&_list_minLength , pattern => \&_pattern , whiteSpace => \&_list_whiteSpace ); my %facets_date = # inclusive or exclusive times is rather useless. ( enumeration => \&_enumeration , explicitTimeZone=> \&_date_expl_tz , maxExclusive => \&_date_max , maxInclusive => \&_date_max , minExclusive => \&_date_min , minInclusive => \&_date_min , pattern => \&_pattern , whiteSpace => \&_date_whitespace ); my %facets_duration = ( enumeration => \&_enumeration , maxExclusive => \&_dur_max_excl , maxInclusive => \&_dur_max_incl , minExclusive => \&_dur_min_excl , minInclusive => \&_dur_min_incl , pattern => \&_pattern , whiteSpace => \&_s_whiteSpace ); my $date_time_type = pack_type SCHEMA2001, 'dateTime'; my $date_type = pack_type SCHEMA2001, 'date'; my $duration_type = pack_type SCHEMA2001, 'duration'; sub builtin_facet($$$$$$$$) { my ($path, $args, $facet, $value, $is_list, $type, $nss, $action) = @_; my $def = $is_list ? $facets_list{$facet} : $nss->doesExtend($type, $date_time_type) ? $facets_date{$facet} : $nss->doesExtend($type, $date_type) ? $facets_date{$facet} : $nss->doesExtend($type, $duration_type) ? $facets_duration{$facet} : $facets_simple{$facet}; $def or error __x"facet {facet} not implemented at {where}" , facet => $facet, where => $path; $def->($path, $args, $value, $type, $nss, $action); } sub _list_whiteSpace($$$) { my ($path, undef, $ws) = @_; $ws eq 'collapse' or error __x"list whiteSpace facet fixed to 'collapse', not '{ws}' in {path}" , ws => $ws, path => $path; (); } sub _s_whiteSpace($$$) { my ($path, undef, $ws) = @_; $ws eq 'replace' ? \&_whitespace_replace : $ws eq 'collapse' ? \&_whitespace_collapse : $ws eq 'preserve' ? () : error __x"illegal whiteSpace facet '{ws}' in {path}" , ws => $ws, path => $path; } sub _date_whiteSpace($$$) { my ($path, undef, $ws) = @_; # whitespace processing already in the dateTime parser $ws eq 'collapse' or error __x"illegal whiteSpace facet '{ws}' in {path}" , ws => $ws, path => $path; (); } sub _whitespace_replace($) { my $value = ref $_[0] ? $_[0]->textContent : $_[0]; $value =~ s/[\t\r\n]/ /gs; $value; } sub _whitespace_collapse($) { my $value = ref $_[0] ? $_[0]->textContent : $_[0]; for($value) { s/[\t\r\n ]+/ /gs; s/^ +//; s/ +$//; } $value; } sub _maybe_big($$$) { my ($path, $args, $value) = @_; return $value if $args->{sloppy_integers}; # modules Math::Big* loaded by Schema::Spec when not sloppy $value =~ s/\s//g; if($value =~ m/[.eE]/) { my $c = $value; my $exp = $c =~ s/[eE][+-]?([0-9]+)// ? $1 : 0; my $pre = $c =~ /^[-+]?([0-9]*)/ ? length($1) : 0; return Math::BigFloat->new($value) if $pre >= DBL_DIG || $pre+$exp >= DBL_MAX_10_EXP; } # compare ints as strings, because they will overflow!! elsif(substr($value, 0, 1) eq '-') { return Math::BigInt->new($value) if length($value) > length(INT_MIN) || (length($value)==length(INT_MIN) && $value gt INT_MIN); } else { return Math::BigInt->new($value) if length($value) > length(INT_MAX) || (length($value)==length(INT_MAX) && $value gt INT_MAX); } $value; } sub _s_minInclusive($$$) { my ($path, $args, $min) = @_; $min = _maybe_big $path, $args, $min; sub { return $_[0] if $_[0] >= $min; error __x"too small inclusive {value}, min {min} at {where}" , value => $_[0], min => $min, where => $path; }; } sub _s_minExclusive($$$) { my ($path, $args, $min) = @_; $min = _maybe_big $path, $args, $min; sub { return $_[0] if $_[0] > $min; error __x"too small exclusive {value}, larger {min} at {where}" , value => $_[0], min => $min, where => $path; }; } sub _s_maxInclusive($$$) { my ($path, $args, $max) = @_; $max = _maybe_big $path, $args, $max; sub { return $_[0] if $_[0] <= $max; error __x"too large inclusive {value}, max {max} at {where}" , value => $_[0], max => $max, where => $path; }; } sub _s_maxExclusive($$$) { my ($path, $args, $max) = @_; $max = _maybe_big $path, $args, $max; sub { return $_[0] if $_[0] < $max; error __x"too large exclusive {value}, smaller {max} at {where}" , value => $_[0], max => $max, where => $path; }; } my $qname = pack_type SCHEMA2001, 'QName'; sub _enumeration($$$$$$) { my ($path, $args, $enums, $type, $nss, $action) = @_; my %enum = map +($_ => 1), @$enums; sub { my $v = ref $_[0] eq 'ARRAY' ? join(' ', @{$_[0]}) : $_[0]; return $v if exists $enum{$v}; error __x"invalid enumerate `{string}' at {where}" , string => $v, where => $path; }; } sub _s_totalDigits($$$) { my ($path, undef, $total) = @_; # this accidentally also works correctly for NaN +INF -INF sub { my $v = $_[0]; $v =~ s/[eE].*//; $v =~ s/^[+-]?0*//; return $_[0] if $total >= ($v =~ tr/0-9//); error __x"decimal too long, got {length} digits max {max} at {where}" , length => ($v =~ tr/0-9//), max => $total, where => $path; }; } sub _s_fractionDigits($$$) { my $frac = $_[2]; # can be result from Math::BigFloat, so too long to use %f But rounding # is very hard to implement. If you need this accuracy, then format your # value yourself! sub { my $v = $_[0]; $v =~ s/(\.[0-9]{$frac}).*/$1/; $v; }; } sub _s_totalFracDigits($$$) { my ($path, undef, $dig) = @_; my ($total, $frac) = @$dig; sub { my $w = $_[0]; my $v = $w; # total is checking length $v =~ s/[eE].*//; $v =~ s/^[+-]?0*//; if( $v !~ /^(?:[+-]?)(?:[0-9]*)(?:\.([0-9]*))?$/ ) { error __x"Invalid numeric format, got {value} at {where}" , value => $w, where => $path; } if($1 && length($1) > $frac) { error __x"fractional part for {value} too long, got {l} digits max {max} at {where}" , value => $w, l => length($1), max => $frac, where => $path; } return $w if $total >= ($v =~ tr/0-9//); error __x"decimal too long, got {length} digits max {max} at {where}" , length => ($v =~ tr/0-9//), max => $total, where => $path; }; } sub _s_length($$$$$$) { my ($path, $args, $len, $type, $nss, $action) = @_; sub { return $_[0] if defined $_[0] && length($_[0])==$len; error __x"string `{string}' does not have required length {len} but {size} at {where}" , string => $_[0], len => $len, size => length($_[0]), where => $path; }; } sub _list_length($$$) { my ($path, $args, $len) = @_; sub { return $_[0] if defined $_[0] && @{$_[0]}==$len; error __x"list `{list}' does not have required length {len} at {where}" , list => $_[0], len => $len, where => $path; }; } sub _s_minLength($$$) { my ($path, $args, $len, $type, $nss, $action) = @_; sub { return $_[0] if defined $_[0] && length($_[0]) >=$len; error __x"string `{string}' does not have minimum length {len} at {where}" , string => $_[0], len => $len, where => $path; }; } sub _list_minLength($$$) { my ($path, $args, $len) = @_; sub { return $_[0] if defined $_[0] && @{$_[0]} >=$len; error __x"list `{list}' does not have minimum length {len} at {where}" , list => $_[0], len => $len, where => $path; }; } sub _s_maxLength($$$) { my ($path, $args, $len, $type, $nss, $action) = @_; sub { return $_[0] if defined $_[0] && length $_[0] <= $len; error __x"string `{string}' longer than maximum length {len} at {where}" , string => $_[0], len => $len, where => $path; }; } sub _list_maxLength($$$) { my ($path, $args, $len) = @_; sub { return $_[0] if defined $_[0] && @{$_[0]} <= $len; error __x"list `{list}' longer than maximum length {len} at {where}" , list => $_[0], len => $len, where => $path; }; } sub _pattern($$$) { my ($path, $args, $pats) = @_; @$pats or return (); my $regex = @$pats==1 ? $pats->[0] : "(".join(')|(', @$pats).")"; my $compiled = XML::LibXML::RegExp->new($regex); sub { use Carp 'cluck'; defined $_[0] or cluck "PATTERN"; my $v = ref $_[0] ? $_[0]->textContent : $_[0]; return $_[0] if $compiled->matches($v); error __x"string `{string}' does not match pattern `{pat}' at {where}" , string => $v, pat => $regex, where => $path; }; } sub _date_min($$$) { my ($path, $args, $min) = @_; sub { return $_[0] if $_[0] gt $min; error __x"too small inclusive {value}, min {min} at {where}" , value => $_[0], min => $min, where => $path; }; } sub _date_max($$$) { my ($path, $args, $max) = @_; sub { return $_[0] if $_[0] lt $max; error __x"too large inclusive {value}, max {max} at {where}" , value => $_[0], max => $max, where => $path; }; } sub _date_expl_tz($$$) { my ($path, $args, $enum) = @_; my $tz = qr/Z$ | [+-](?:(?:0[0-9]|1[0-3])\:[0-5][0-9] | 14\:00)$/x; $enum eq 'optional' ? () : $enum eq 'prohibited' ? sub { $_[0] !~ $tz or error __x"timezone forbidden on {date} at {where}" , date => $_[0], where => $path; } : $enum eq 'required' ? sub { $_[0] =~ $tz or error __x"timezone required on {date} at {where}" , date => $_[0], where => $path; } : error __x"illegal explicitTimeZone facet '{enum}' in {path}" , enum => $enum, path => $path; } sub _dur_min_incl($$$) { my ($path, $args, $min) = @_; my $secs = duration2secs $min; sub { return $_[0] if duration2secs $_[0] >= $secs; error __x"too small minInclusive duration {value}, min {min} at {where}" , value => $_[0], min => $min, where => $path; }; } sub _dur_min_excl($$$) { my ($path, $args, $min) = @_; my $secs = duration2secs $min; sub { return $_[0] if duration2secs $_[0] > $secs; error __x"too small minExclusive duration {value}, min {min} at {where}" , value => $_[0], min => $min, where => $path; }; } sub _dur_max_incl($$$) { my ($path, $args, $max) = @_; my $secs = duration2secs $max; sub { return $_[0] if duration2secs $_[0] <= $secs; error __x"too large maxInclusive duration {value}, max {max} at {where}" , value => $_[0], max => $max, where => $path; }; } sub _dur_max_excl($$$) { my ($path, $args, $max) = @_; my $secs = duration2secs $max; sub { return $_[0] if duration2secs $_[0] < $secs; error __x"too large maxExclusive duration {value}, max {max} at {where}" , value => $_[0], max => $max, where => $path; }; } 1; XML-Compile-1.58/lib/XML/Compile/Schema/NameSpaces.pm0000644000175000001440000001541513124470276022602 0ustar00markovusers00000000000000# Copyrights 2006-2017 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.02. use warnings; use strict; package XML::Compile::Schema::NameSpaces; use vars '$VERSION'; $VERSION = '1.58'; use Log::Report 'xml-compile', syntax => 'SHORT'; 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.58/lib/XML/Compile/Schema/BuiltInTypes.pod0000644000175000001440000002257313124470314023320 0ustar00markovusers00000000000000=encoding utf8 =head1 NAME XML::Compile::Schema::BuiltInTypes - Define handling of built-in data-types =head1 INHERITANCE XML::Compile::Schema::BuiltInTypes is a 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