File Coverage

lib/XML/Compile/Schema/Instance.pm
Criterion Covered Total %
statement 130 149 87.2
branch 39 62 62.9
condition 23 42 54.7
subroutine 24 32 75.0
pod 23 24 95.8
total 239 309 77.3


line stmt bran cond sub pod time code
1             # Copyrights 2006-2019 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of distribution XML-Compile. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package XML::Compile::Schema::Instance;
10 50     50   357 use vars '$VERSION';
  50         103  
  50         2835  
11             $VERSION = '1.62';
12              
13              
14 50     50   291 use warnings;
  50         98  
  50         1303  
15 50     50   239 use strict;
  50         94  
  50         1084  
16              
17 50     50   236 use Log::Report 'xml-compile';
  50         109  
  50         465  
18 50     50   14916 use XML::Compile::Schema::Specs;
  50         103  
  50         1442  
19 50     50   266 use XML::Compile::Util qw/pack_type unpack_type/;
  50         103  
  50         2704  
20 50     50   343 use Scalar::Util qw/weaken/;
  50         141  
  50         92474  
21              
22             my @defkinds = qw/element attribute simpleType complexType
23             attributeGroup group/;
24             my %defkinds = map +($_ => 1), @defkinds;
25              
26              
27             sub new($@)
28 58     58 1 147 { my $class = shift;
29 58         381 (bless {}, $class)->init( {top => @_} );
30             }
31              
32             sub init($)
33 58     58 0 153 { my ($self, $args) = @_;
34 58         145 my $top = $args->{top};
35 58 50 33     534 defined $top && $top->isa('XML::LibXML::Node')
36             or panic "instance is based on XML node";
37              
38 58         317 $self->{filename} = $args->{filename};
39 58         163 $self->{source} = $args->{source};
40 58         697 $self->{$_} = {} for @defkinds, 'sgs', 'import';
41 58         169 $self->{include} = [];
42              
43 58         285 $self->_collectTypes($top, $args);
44 58         441 $self;
45             }
46              
47              
48 1     1 1 13 sub targetNamespace { shift->{tns} }
49 0     0 1 0 sub schemaNamespace { shift->{xsd} }
50 0     0 1 0 sub schemaInstance { shift->{xsi} }
51 1     1 1 5 sub source { shift->{source} }
52 1     1 1 7 sub filename { shift->{filename} }
53 0     0 1 0 sub schema { shift->{schema} }
54              
55              
56 58     58 1 112 sub tnses() {keys %{shift->{tnses}}}
  58         368  
57              
58              
59 63     63 1 491 sub sgs() { shift->{sgs} }
60              
61              
62 0     0 1 0 sub type($) { $_[0]->{types}{$_[1]} }
63              
64              
65 0     0 1 0 sub element($) { $_[0]->{element}{$_[1]} }
66              
67              
68 5     5 1 7 sub elements() { keys %{shift->{element}} }
  5         48  
69 1     1 1 3 sub attributes() { keys %{shift->{attributes}} }
  1         7  
70 1     1 1 2 sub attributeGroups() { keys %{shift->{attributeGroup}} }
  1         5  
71 1     1 1 2 sub groups() { keys %{shift->{group}} }
  1         6  
72 5     5 1 2191 sub simpleTypes() { keys %{shift->{simpleType}} }
  5         28  
73 7     7 1 12 sub complexTypes() { keys %{shift->{complexType}} }
  7         67  
74              
75              
76 4     4 1 14 sub types() { ($_[0]->simpleTypes, $_[0]->complexTypes) }
77              
78              
79             my %skip_toplevel = map +($_ => 1), qw/annotation notation redefine/;
80              
81             sub _collectTypes($$)
82 58     58   180 { my ($self, $schema, $args) = @_;
83              
84 58 50       365 $schema->localName eq 'schema'
85             or panic "requires schema element";
86              
87 58   50     563 my $xsd = $self->{xsd} = $schema->namespaceURI || '';
88 58 50       282 if(length $xsd)
89             { my $def = $self->{def}
90 58 50       478 = XML::Compile::Schema::Specs->predefinedSchema($xsd)
91             or error __x"schema namespace `{namespace}' not (yet) supported"
92             , namespace => $xsd;
93              
94 58         274 $self->{xsi} = $def->{uri_xsi};
95             }
96              
97 58         135 my $tns;
98 58 100       218 if($tns = $args->{target_namespace})
99 1         9 { $schema->removeAttribute('targetNamespace');
100 1         5 $schema->setAttribute(targetNamespace => $tns);
101             }
102             else
103 57   100     309 { $tns = $schema->getAttribute('targetNamespace') || '';
104             }
105 58         1078 $self->{tns} = $tns;
106              
107             $self->{efd} = $args->{element_form_default}
108 58   100     325 || $schema->getAttribute('elementFormDefault')
109             || 'unqualified';
110              
111             $self->{afd} = $args->{attribute_form_default}
112 58   100     1071 || $schema->getAttribute('attributeFormDefault')
113             || 'unqualified';
114              
115 58         826 $self->{tnses} = {}; # added when used
116 58         145 $self->{types} = {};
117              
118 58         134 $self->{schema} = $schema;
119 58         290 weaken($self->{schema});
120              
121             NODE:
122 58         396 foreach my $node ($schema->childNodes)
123 1010 100       7253 { next unless $node->isa('XML::LibXML::Element');
124 443         1071 my $local = $node->localName;
125 443   50     1270 my $myns = $node->namespaceURI || '';
126 443 50 0     834 $myns eq $xsd
127             or error __x"schema element `{name}' not in schema namespace {ns} but {other}"
128             , name => $local, ns => $xsd, other => ($myns || '');
129              
130             next
131 443 100       886 if $skip_toplevel{$local};
132              
133 433 100       793 if($local eq 'import')
134 1   33     4 { my $namespace = $node->getAttribute('namespace') || $tns;
135 1   50     11 my $location = $node->getAttribute('schemaLocation') || '';
136 1         9 push @{$self->{import}{$namespace}}, $location;
  1         4  
137 1         2 next NODE;
138             }
139              
140 432 50       734 if($local eq 'include')
141 0 0       0 { my $location = $node->getAttribute('schemaLocation')
142             or error __x"include requires schemaLocation attribute at line {linenr}"
143             , linenr => $node->line_number;
144              
145 0         0 push @{$self->{include}}, $location;
  0         0  
146 0         0 next NODE;
147             }
148              
149 432 50       880 unless($defkinds{$local})
150 0         0 { mistake __x"ignoring unknown definition class {class}"
151             , class => $local;
152 0         0 next;
153             }
154              
155 432 50       870 my $name = $node->getAttribute('name')
156             or error __x"schema component {local} without name at line {linenr}"
157             , local => $local, linenr => $node->line_number;
158              
159 432   66     3763 my $tns = $node->getAttribute('targetNamespace') || $tns;
160 432         4089 my $type = pack_type $tns, $name;
161 432         924 $self->{tnses}{$tns}++;
162 432         1121 $self->{$local}{$type} = $node;
163              
164 432 100       867 if(my $sg = $node->getAttribute('substitutionGroup'))
165 5 50       88 { my ($prefix, $l) = $sg =~ m/:/ ? split(/:/, $sg, 2) : ('',$sg);
166 5         36 my $base = pack_type $node->lookupNamespaceURI($prefix), $l;
167 5         20 push @{$self->{sgs}{$base}}, $type;
  5         28  
168             }
169             }
170              
171 58         524 $self;
172             }
173              
174              
175 0     0 1 0 sub includeLocations() { @{shift->{include}} }
  0         0  
176              
177              
178 0     0 1 0 sub imports() { keys %{shift->{import}} }
  0         0  
179              
180              
181             sub importLocations($)
182 0     0 1 0 { my $locs = $_[0]->{import}{$_[1]};
183 0 0       0 $locs ? @$locs : ();
184             }
185              
186              
187             sub printIndex(;$)
188 1     1 1 1629 { my $self = shift;
189 1 50       6 my $fh = @_ % 2 ? shift : select;
190 1         2 my %args = @_;
191              
192 1         6 $fh->print("namespace: ", $self->targetNamespace, "\n");
193 1 50       11 if(defined(my $filename = $self->filename))
    50          
194 0         0 { $fh->print(" filename: $filename\n");
195             }
196             elsif(defined(my $source = $self->source))
197 1         5 { $fh->print(" source: $source\n");
198             }
199              
200             my @kinds
201             = ! defined $args{kinds} ? @defkinds
202 0         0 : ref $args{kinds} eq 'ARRAY' ? @{$args{kinds}}
203 1 0       11 : $args{kinds};
    50          
204              
205             my $list_abstract
206 1 50       4 = exists $args{list_abstract} ? $args{list_abstract} : 1;
207              
208 1         3 foreach my $kind (@kinds)
209 6         39 { my $table = $self->{$kind};
210 6 100       17 keys %$table or next;
211 5 50       21 $fh->print(" definitions of ${kind}s:\n") if @kinds > 1;
212              
213 5         112 foreach (sort keys %$table)
214 145         917 { my $info = $self->find($kind, $_);
215 145         241 my ($ns, $name) = unpack_type $_;
216 145 50 66     275 next if $info->{abstract} && ! $list_abstract;
217 145 100       188 my $abstract = $info->{abstract} ? ' [abstract]' : '';
218 145 50       179 my $final = $info->{final} ? ' [final]' : '';
219 145         424 $fh->print(" $name$abstract$final\n");
220             }
221             }
222             }
223              
224              
225             sub find($$)
226 2691     2691 1 5587 { my ($self, $kind, $full) = @_;
227 2691 100       8515 my $node = $self->{$kind}{$full}
228             or return;
229              
230 2428 100       8763 return $node # translation of XML node into info is cached
231             if ref $node eq 'HASH';
232              
233 428         1534 my %info = (type => $kind, node => $node, full => $full);
234 428         1113 @info{'ns', 'name'} = unpack_type $full;
235              
236 428         1345 $self->{$kind}{$full} = \%info;
237              
238 428   100     1214 my $abstract = $node->getAttribute('abstract') || '';
239 428   66     6782 $info{abstract} = $abstract eq 'true' || $abstract eq '1';
240              
241 428   50     1017 my $final = $node->getAttribute('final') || '';
242 428   33     4944 $info{final} = $final eq 'true' || $final eq '1';
243              
244 428         1344 my $local = $node->localName;
245 428 100       1158 if($local eq 'element') { $info{efd} = $node->getAttribute('form') }
  241 100       566  
246 4         10 elsif($local eq 'attribute'){ $info{afd} = $node->getAttribute('form') }
247 428   33     3833 $info{efd} ||= $self->{efd}; # both needed for nsContext
248 428   33     1728 $info{afd} ||= $self->{afd};
249 428         1028 \%info;
250             }
251              
252             1;