1 |
wakaba |
1.1 |
package Whatpm::RDFXML; |
2 |
|
|
use strict; |
3 |
|
|
|
4 |
|
|
## NOTE: EntityReference nodes are not supported except that |
5 |
|
|
## unexpected entity reference are simply ignored. (In fact |
6 |
|
|
## all EntityRefernce nodes are ignored.) |
7 |
|
|
|
8 |
wakaba |
1.2 |
## TODO: Add a callback function invoked for every element |
9 |
|
|
## when XMLCC is implemented in WDCC. |
10 |
|
|
|
11 |
|
|
## ISSUE: <html:nest/> in RDF subtree? |
12 |
|
|
|
13 |
|
|
## ISSUE: PIs in RDF subtree should be validated? |
14 |
|
|
|
15 |
wakaba |
1.5 |
## TODO: Should we validate expanded URI created from QName? |
16 |
|
|
|
17 |
|
|
## TODO: elements in null namespace (not mentioned in the spec.) |
18 |
|
|
|
19 |
wakaba |
1.1 |
my $RDF_URI = q<http://www.w3.org/1999/02/22-rdf-syntax-ns#>; |
20 |
|
|
|
21 |
wakaba |
1.8 |
use Char::Class::XML qw(InXML_NCNameStartChar10 InXMLNCNameChar10); |
22 |
wakaba |
1.5 |
require Whatpm::URIChecker; |
23 |
|
|
|
24 |
wakaba |
1.1 |
sub new ($) { |
25 |
wakaba |
1.5 |
my $self = bless {fact_level => 'm', grammer_level => 'm', |
26 |
|
|
info_level => 'i', next_id => 0}, shift; |
27 |
wakaba |
1.1 |
$self->{onerror} = sub { |
28 |
|
|
my %opt = @_; |
29 |
|
|
warn $opt{type}, "\n"; |
30 |
|
|
}; |
31 |
|
|
$self->{ontriple} = sub { |
32 |
|
|
my %opt = @_; |
33 |
|
|
my $dump_resource = sub { |
34 |
|
|
my $resource = shift; |
35 |
wakaba |
1.3 |
if (defined $resource->{uri}) { |
36 |
wakaba |
1.1 |
return '<' . $resource->{uri} . '>'; |
37 |
wakaba |
1.3 |
} elsif (defined $resource->{bnodeid}) { |
38 |
wakaba |
1.1 |
return '_:' . $resource->{bnodeid}; |
39 |
|
|
} elsif ($resource->{nodes}) { |
40 |
|
|
return '"' . join ('', map {$_->inner_html} @{$resource->{nodes}}) . |
41 |
|
|
'"^^<' . $resource->{datatype} . '>'; |
42 |
|
|
} elsif (defined $resource->{value}) { |
43 |
|
|
return '"' . $resource->{value} . '"' . |
44 |
|
|
(defined $resource->{datatype} |
45 |
|
|
? '^^<' . $resource->{datatype} . '>' |
46 |
|
|
: '@' . $resource->{language}); |
47 |
|
|
} else { |
48 |
|
|
return '??'; |
49 |
|
|
} |
50 |
|
|
}; |
51 |
|
|
print STDERR $dump_resource->($opt{subject}) . ' '; |
52 |
|
|
print STDERR $dump_resource->($opt{predicate}) . ' '; |
53 |
|
|
print STDERR $dump_resource->($opt{object}) . "\n"; |
54 |
wakaba |
1.3 |
if ($dump_resource->{id}) { |
55 |
|
|
print STDERR $dump_resource->($dump_resource->{id}) . ' '; |
56 |
|
|
print STDERR $dump_resource->({uri => $RDF_URI . 'subject'}) . ' '; |
57 |
|
|
print STDERR $dump_resource->($opt{subject}) . "\n"; |
58 |
|
|
print STDERR $dump_resource->($dump_resource->{id}) . ' '; |
59 |
|
|
print STDERR $dump_resource->({uri => $RDF_URI . 'predicate'}) . ' '; |
60 |
|
|
print STDERR $dump_resource->($opt{predicate}) . "\n"; |
61 |
|
|
print STDERR $dump_resource->($dump_resource->{id}) . ' '; |
62 |
|
|
print STDERR $dump_resource->({uri => $RDF_URI . 'object'}) . ' '; |
63 |
|
|
print STDERR $dump_resource->($opt{object}) . "\n"; |
64 |
|
|
print STDERR $dump_resource->($dump_resource->{id}) . ' '; |
65 |
|
|
print STDERR $dump_resource->({uri => $RDF_URI . 'type'}) . ' '; |
66 |
|
|
print STDERR $dump_resource->({uri => $RDF_URI . 'Statement'}) . "\n"; |
67 |
|
|
} |
68 |
wakaba |
1.1 |
}; |
69 |
|
|
return $self; |
70 |
|
|
} # new |
71 |
|
|
|
72 |
|
|
sub convert_document ($$) { |
73 |
|
|
my $self = shift; |
74 |
|
|
my $node = shift; # Document |
75 |
|
|
|
76 |
|
|
## ISSUE: An RDF/XML document, either |doc| or |nodeElement| |
77 |
|
|
## is allowed as a starting production. However, |nodeElement| |
78 |
|
|
## is not a Root Event. |
79 |
|
|
|
80 |
|
|
my $has_element; |
81 |
|
|
|
82 |
|
|
for my $cn (@{$node->child_nodes}) { |
83 |
|
|
if ($cn->node_type == $cn->ELEMENT_NODE) { |
84 |
|
|
unless ($has_element) { |
85 |
|
|
if ($cn->manakai_expanded_uri eq $RDF_URI . q<RDF>) { |
86 |
wakaba |
1.7 |
$self->convert_rdf_element ($cn, language => ''); |
87 |
wakaba |
1.1 |
} else { |
88 |
wakaba |
1.7 |
$self->convert_rdf_node_element ($cn, language => ''); |
89 |
wakaba |
1.1 |
} |
90 |
|
|
$has_element = 1; |
91 |
|
|
} else { |
92 |
|
|
$self->{onerror}->(type => 'second node element', |
93 |
|
|
level => $self->{grammer_level}, |
94 |
|
|
node => $cn); |
95 |
|
|
} |
96 |
|
|
} elsif ($cn->node_type == $cn->TEXT_NODE or |
97 |
|
|
$cn->node_type == $cn->CDATA_SECTION_NODE) { |
98 |
|
|
$self->{onerror}->(type => 'character not allowed', |
99 |
|
|
level => $self->{grammer_level}, |
100 |
|
|
node => $cn); |
101 |
|
|
} |
102 |
|
|
} |
103 |
|
|
} # convert_document |
104 |
|
|
|
105 |
|
|
my $check_rdf_namespace = sub { |
106 |
|
|
my $self = shift; |
107 |
|
|
my $node = shift; |
108 |
|
|
my $node_nsuri = $node->namespace_uri; |
109 |
|
|
return unless defined $node_nsuri; |
110 |
|
|
if (substr ($node_nsuri, 0, length $RDF_URI) eq $RDF_URI and |
111 |
|
|
length $RDF_URI < length $node_nsuri) { |
112 |
|
|
$self->{onerror}->(type => 'bad rdf namespace', |
113 |
|
|
level => $self->{fact_level}, # Section 5.1 |
114 |
|
|
node => $node); |
115 |
|
|
} |
116 |
|
|
}; # $check_rdf_namespace |
117 |
|
|
|
118 |
wakaba |
1.7 |
sub convert_rdf_element ($$%) { |
119 |
|
|
my ($self, $node, %opt) = @_; |
120 |
|
|
$opt{language} = '' unless defined $opt{language}; |
121 |
|
|
## ISSUE: Not explicitly defined in the spec. |
122 |
wakaba |
1.1 |
|
123 |
|
|
$check_rdf_namespace->($self, $node); |
124 |
|
|
|
125 |
|
|
# |RDF| |
126 |
|
|
|
127 |
|
|
for my $attr (@{$node->attributes}) { |
128 |
wakaba |
1.7 |
my $nsuri = $attr->namespace_uri; |
129 |
|
|
if (defined $nsuri and |
130 |
|
|
$nsuri eq q<http://www.w3.org/XML/1998/namespace> and |
131 |
|
|
$attr->manakai_local_name eq 'lang') { |
132 |
|
|
$opt{language} = $attr->value; |
133 |
|
|
next; |
134 |
|
|
} |
135 |
|
|
|
136 |
wakaba |
1.1 |
my $prefix = $attr->prefix; |
137 |
|
|
if (defined $prefix) { |
138 |
|
|
next if $prefix =~ /^[Xx][Mm][Ll]/; |
139 |
|
|
} else { |
140 |
|
|
next if $attr->manakai_local_name =~ /^[Xx][Mm][Ll]/; |
141 |
|
|
} |
142 |
|
|
|
143 |
|
|
$check_rdf_namespace->($self, $attr); |
144 |
|
|
$self->{onerror}->(type => 'attribute not allowed', |
145 |
|
|
level => $self->{grammer_level}, |
146 |
|
|
node => $attr); |
147 |
|
|
} |
148 |
|
|
|
149 |
|
|
# |nodeElementList| |
150 |
|
|
for my $cn (@{$node->child_nodes}) { |
151 |
|
|
if ($cn->node_type == $cn->ELEMENT_NODE) { |
152 |
wakaba |
1.7 |
$self->convert_node_element ($cn, language => $opt{language}); |
153 |
wakaba |
1.1 |
} elsif ($cn->node_type == $cn->TEXT_NODE or |
154 |
|
|
$cn->node_type == $cn->CDATA_SECTION_NODE) { |
155 |
|
|
if ($cn->data =~ /[^\x09\x0A\x0D\x20]/) { |
156 |
|
|
$self->{onerror}->(type => 'character not allowed', |
157 |
|
|
level => $self->{grammer_level}, |
158 |
|
|
node => $cn); |
159 |
|
|
} |
160 |
|
|
} |
161 |
|
|
} |
162 |
|
|
} # convert_rdf_element |
163 |
|
|
|
164 |
|
|
my %coreSyntaxTerms = ( |
165 |
|
|
$RDF_URI . 'RDF' => 1, |
166 |
|
|
$RDF_URI . 'ID' => 1, |
167 |
|
|
$RDF_URI . 'about' => 1, |
168 |
|
|
$RDF_URI . 'parseType' => 1, |
169 |
|
|
$RDF_URI . 'resource' => 1, |
170 |
|
|
$RDF_URI . 'nodeID' => 1, |
171 |
|
|
$RDF_URI . 'datatype' => 1, |
172 |
|
|
); |
173 |
|
|
|
174 |
|
|
my %oldTerms = ( |
175 |
|
|
$RDF_URI . 'aboutEach' => 1, |
176 |
|
|
$RDF_URI . 'aboutEachPrefix' => 1, |
177 |
|
|
$RDF_URI . 'bagID' => 1, |
178 |
|
|
); |
179 |
|
|
|
180 |
wakaba |
1.4 |
require Message::DOM::DOMImplementation; |
181 |
|
|
my $resolve = sub { |
182 |
|
|
return Message::DOM::DOMImplementation->create_uri_reference ($_[0]) |
183 |
|
|
->get_absolute_reference ($_[1]->base_uri) |
184 |
|
|
->uri_reference; |
185 |
|
|
|
186 |
wakaba |
1.5 |
## TODO: Ummm... RDF/XML spec refers dated version of xml:base and RFC 2396... |
187 |
|
|
|
188 |
wakaba |
1.4 |
## TODO: Check latest xml:base and IRI spec... |
189 |
|
|
## (non IRI/URI chars should be percent-encoded before resolve?) |
190 |
|
|
}; # $resolve |
191 |
|
|
|
192 |
|
|
my $generate_bnodeid = sub { |
193 |
|
|
return 'g'.$_[0]->{next_id}++; |
194 |
|
|
}; # $generate_bnodeid |
195 |
|
|
|
196 |
|
|
my $get_bnodeid = sub { |
197 |
|
|
return 'b'.$_[0]; |
198 |
|
|
}; # $get_bnodeid |
199 |
|
|
|
200 |
wakaba |
1.5 |
my $uri_attr = sub { |
201 |
|
|
my ($self, $attr) = @_; |
202 |
|
|
|
203 |
|
|
my $abs_uri = $resolve->($attr->value, $attr); |
204 |
|
|
|
205 |
|
|
Whatpm::URIChecker->check_iri_reference ($abs_uri, sub { |
206 |
|
|
my %opt = @_; |
207 |
|
|
$self->{onerror}->(node => $attr, level => $opt{level}, |
208 |
|
|
type => 'URI::'.$opt{type}. |
209 |
|
|
(defined $opt{position} ? ':'.$opt{position} : '')); |
210 |
|
|
}); |
211 |
|
|
|
212 |
|
|
return $abs_uri; |
213 |
wakaba |
1.6 |
}; # $uri_attr |
214 |
|
|
|
215 |
|
|
my $id_attr = sub { |
216 |
|
|
my ($self, $attr) = @_; |
217 |
|
|
|
218 |
|
|
my $id = $attr->value; |
219 |
|
|
unless ($id =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) { |
220 |
|
|
$self->{onerror}->(type => 'syntax error', ## TODO: type |
221 |
|
|
level => $self->{grammer_level}, |
222 |
|
|
node => $attr); |
223 |
|
|
} |
224 |
wakaba |
1.7 |
|
225 |
|
|
my $base_uri = $attr->base_uri; |
226 |
|
|
if ($self->{id}->{$base_uri}->{$id}) { |
227 |
|
|
$self->{onerror}->(type => 'duplicate rdf id', ## TODO: type |
228 |
|
|
level => $self->{small_must_level}, |
229 |
|
|
node => $attr); |
230 |
|
|
## TODO: RDF Validator? |
231 |
|
|
} else { |
232 |
|
|
$self->{id}->{$base_uri}->{$id} = 1; |
233 |
|
|
} |
234 |
wakaba |
1.6 |
|
235 |
|
|
return $resolve->('#' . $id, $attr); |
236 |
wakaba |
1.7 |
}; # $id_attr |
237 |
wakaba |
1.5 |
|
238 |
wakaba |
1.7 |
my $check_local_attr = sub { |
239 |
|
|
my ($self, $node, $attr, $attr_xuri) = @_; |
240 |
|
|
|
241 |
|
|
if ({ |
242 |
|
|
ID => 1, about => 1, resource => 1, parseType => 1, type => 1, |
243 |
|
|
}->{$attr_xuri}) { |
244 |
|
|
$self->{onerror}->(type => 'unqualified rdf attr', ## TODO: type |
245 |
|
|
level => $self->{should_level}, |
246 |
|
|
node => $attr); |
247 |
|
|
if ($node->has_attribute_ns ($RDF_URI, $attr_xuri)) { |
248 |
|
|
$self->{onerror}->(type => 'duplicate unqualified attr',## TODO: type |
249 |
|
|
level => $self->{fact_level}, |
250 |
|
|
node => $attr); |
251 |
|
|
## NOTE: <? rdfa:bout="" about=""> and such are not catched |
252 |
|
|
## by this check; but who cares? rdfa:bout="" is itself illegal. |
253 |
|
|
} |
254 |
|
|
$attr_xuri = $RDF_URI . $attr_xuri; |
255 |
|
|
} else { |
256 |
|
|
$self->{onerror}->(type => 'unqualified attr', ## TODO: type |
257 |
|
|
level => $self->{fact_level}, |
258 |
|
|
node => $attr); |
259 |
|
|
## TODO: RDF Validator? |
260 |
|
|
} |
261 |
|
|
|
262 |
|
|
return $attr_xuri; |
263 |
|
|
}; # $check_local_attr |
264 |
wakaba |
1.5 |
|
265 |
wakaba |
1.7 |
sub convert_node_element ($$;%) { |
266 |
|
|
my ($self, $node, %opt) = @_; |
267 |
|
|
$opt{language} = '' unless defined $opt{language}; |
268 |
|
|
## ISSUE: Not explicitly defined in the spec. |
269 |
wakaba |
1.1 |
|
270 |
|
|
$check_rdf_namespace->($self, $node); |
271 |
|
|
|
272 |
|
|
# |nodeElement| |
273 |
|
|
|
274 |
|
|
my $xuri = $node->manakai_expanded_uri; |
275 |
|
|
|
276 |
|
|
if ({ |
277 |
|
|
%coreSyntaxTerms, |
278 |
|
|
$RDF_URI . 'li' => 1, |
279 |
|
|
%oldTerms, |
280 |
|
|
}->{$xuri}) { |
281 |
|
|
$self->{onerror}->(type => 'element not allowed', |
282 |
|
|
level => $self->{grammer_level}, |
283 |
|
|
node => $node); |
284 |
|
|
|
285 |
|
|
## TODO: W3C RDF Validator: Continue validation, but triples that would |
286 |
|
|
## be generated from the subtree are ignored. |
287 |
|
|
} |
288 |
|
|
|
289 |
|
|
my $subject; |
290 |
wakaba |
1.4 |
my $type_attr; |
291 |
wakaba |
1.1 |
my @prop_attr; |
292 |
|
|
|
293 |
|
|
for my $attr (@{$node->attributes}) { |
294 |
wakaba |
1.7 |
my $nsuri = $attr->namespace_uri; |
295 |
|
|
if (defined $nsuri and |
296 |
|
|
$nsuri eq q<http://www.w3.org/XML/1998/namespace> and |
297 |
|
|
$attr->manakai_local_name eq 'lang') { |
298 |
|
|
$opt{language} = $attr->value; |
299 |
|
|
} |
300 |
|
|
|
301 |
wakaba |
1.1 |
my $prefix = $attr->prefix; |
302 |
|
|
if (defined $prefix) { |
303 |
|
|
next if $prefix =~ /^[Xx][Mm][Ll]/; |
304 |
|
|
} else { |
305 |
|
|
next if $attr->manakai_local_name =~ /^[Xx][Mm][Ll]/; |
306 |
|
|
} |
307 |
|
|
|
308 |
|
|
$check_rdf_namespace->($self, $attr); |
309 |
|
|
|
310 |
|
|
my $attr_xuri = $attr->manakai_expanded_uri; |
311 |
wakaba |
1.7 |
|
312 |
|
|
unless (defined $nsuri) { |
313 |
|
|
$attr_xuri = $check_local_attr->($self, $node, $attr, $attr_xuri); |
314 |
|
|
} |
315 |
|
|
|
316 |
wakaba |
1.2 |
if ($attr_xuri eq $RDF_URI . 'ID') { |
317 |
wakaba |
1.1 |
unless (defined $subject) { |
318 |
wakaba |
1.6 |
$subject = {uri => $id_attr->($self, $attr)}; |
319 |
wakaba |
1.1 |
} else { |
320 |
wakaba |
1.5 |
$self->{onerror}->(type => 'attribute not allowed', |
321 |
|
|
level => $self->{grammer_level}, |
322 |
|
|
node => $attr); |
323 |
|
|
|
324 |
wakaba |
1.1 |
## TODO: Ignore triple as W3C RDF Validator does |
325 |
|
|
} |
326 |
|
|
} elsif ($attr_xuri eq $RDF_URI . 'nodeID') { |
327 |
|
|
unless (defined $subject) { |
328 |
wakaba |
1.5 |
my $id = $attr->value; |
329 |
|
|
unless ($id =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) { |
330 |
|
|
$self->{onerror}->(type => 'syntax error', ## TODO: type |
331 |
|
|
level => $self->{grammer_level}, |
332 |
|
|
node => $self); |
333 |
|
|
} |
334 |
|
|
|
335 |
|
|
$subject = {bnodeid => $get_bnodeid->($id)}; |
336 |
wakaba |
1.1 |
} else { |
337 |
wakaba |
1.5 |
$self->{onerror}->(type => 'attribute not allowed', |
338 |
|
|
level => $self->{grammer_level}, |
339 |
|
|
node => $attr); |
340 |
|
|
|
341 |
wakaba |
1.1 |
## TODO: Ignore triple as W3C RDF Validator does |
342 |
|
|
} |
343 |
|
|
} elsif ($attr_xuri eq $RDF_URI . 'about') { |
344 |
|
|
unless (defined $subject) { |
345 |
wakaba |
1.5 |
$subject = {uri => $uri_attr->($self, $attr)}; |
346 |
wakaba |
1.1 |
} else { |
347 |
wakaba |
1.5 |
$self->{onerror}->(type => 'attribute not allowed', |
348 |
|
|
level => $self->{grammer_level}, |
349 |
|
|
node => $attr); |
350 |
|
|
|
351 |
wakaba |
1.1 |
## TODO: Ignore triple as W3C RDF Validator does |
352 |
|
|
} |
353 |
|
|
} elsif ($attr_xuri eq $RDF_URI . 'type') { |
354 |
wakaba |
1.4 |
$type_attr = $attr; |
355 |
wakaba |
1.1 |
} elsif ({ |
356 |
|
|
%coreSyntaxTerms, |
357 |
|
|
$RDF_URI . 'li' => 1, |
358 |
|
|
$RDF_URI . 'Description' => 1, |
359 |
|
|
%oldTerms, |
360 |
|
|
}->{$attr_xuri}) { |
361 |
|
|
$self->{onerror}->(type => 'attribute not allowed', |
362 |
|
|
level => $self->{grammer_level}, |
363 |
|
|
node => $attr); |
364 |
|
|
|
365 |
|
|
## TODO: W3C RDF Validator: Ignore triples |
366 |
|
|
} else { |
367 |
|
|
push @prop_attr, $attr; |
368 |
|
|
} |
369 |
|
|
} |
370 |
|
|
|
371 |
|
|
unless (defined $subject) { |
372 |
wakaba |
1.4 |
$subject = {bnodeid => $generate_bnodeid->($self)}; |
373 |
wakaba |
1.1 |
} |
374 |
|
|
|
375 |
|
|
if ($xuri ne $RDF_URI . 'Description') { |
376 |
|
|
$self->{ontriple}->(subject => $subject, |
377 |
|
|
predicate => {uri => $RDF_URI . 'type'}, |
378 |
wakaba |
1.2 |
object => {uri => $xuri}, |
379 |
|
|
node => $node); |
380 |
wakaba |
1.1 |
} |
381 |
|
|
|
382 |
wakaba |
1.4 |
if ($type_attr) { |
383 |
wakaba |
1.1 |
$self->{ontriple}->(subject => $subject, |
384 |
|
|
predicate => {uri => $RDF_URI . 'type'}, |
385 |
wakaba |
1.4 |
object => {uri => $resolve->($type_attr->value, |
386 |
|
|
$type_attr)}, |
387 |
|
|
node => $type_attr); |
388 |
wakaba |
1.1 |
} |
389 |
|
|
|
390 |
|
|
for my $attr (@prop_attr) { |
391 |
|
|
$self->{ontriple}->(subject => $subject, |
392 |
|
|
predicate => {uri => $attr->manakai_expanded_uri}, |
393 |
wakaba |
1.7 |
object => {value => $attr->value, |
394 |
|
|
language => $opt{language}}, |
395 |
wakaba |
1.2 |
node => $attr); |
396 |
wakaba |
1.1 |
## TODO: SHOULD in NFC |
397 |
|
|
} |
398 |
|
|
|
399 |
|
|
# |propertyEltList| |
400 |
|
|
|
401 |
|
|
my $li_counter = 1; |
402 |
|
|
for my $cn (@{$node->child_nodes}) { |
403 |
|
|
my $cn_type = $cn->node_type; |
404 |
|
|
if ($cn_type == $cn->ELEMENT_NODE) { |
405 |
|
|
$self->convert_property_element ($cn, li_counter => \$li_counter, |
406 |
wakaba |
1.7 |
subject => $subject, |
407 |
|
|
language => $opt{language}); |
408 |
wakaba |
1.1 |
} elsif ($cn_type == $cn->TEXT_NODE or |
409 |
|
|
$cn_type == $cn->CDATA_SECTION_NODE) { |
410 |
|
|
if ($cn->data =~ /[^\x09\x0A\x0D\x20]/) { |
411 |
|
|
$self->{onerror}->(type => 'character not allowed', |
412 |
|
|
level => $self->{grammer_level}, |
413 |
|
|
node => $cn); |
414 |
|
|
} |
415 |
|
|
} |
416 |
|
|
} |
417 |
|
|
|
418 |
|
|
return $subject; |
419 |
|
|
} # convert_node_element |
420 |
|
|
|
421 |
wakaba |
1.4 |
my $get_id_resource = sub { |
422 |
wakaba |
1.5 |
my $self = shift; |
423 |
|
|
my $node = shift; |
424 |
wakaba |
1.6 |
|
425 |
wakaba |
1.5 |
return undef unless $node; |
426 |
wakaba |
1.6 |
|
427 |
|
|
return {uri => $id_attr->($self, $node)}; |
428 |
wakaba |
1.4 |
}; # $get_id_resource |
429 |
|
|
|
430 |
wakaba |
1.1 |
sub convert_property_element ($$%) { |
431 |
|
|
my ($self, $node, %opt) = @_; |
432 |
|
|
|
433 |
|
|
$check_rdf_namespace->($self, $node); |
434 |
|
|
|
435 |
|
|
# |propertyElt| |
436 |
|
|
|
437 |
|
|
my $xuri = $node->manakai_expanded_uri; |
438 |
|
|
if ($xuri eq $RDF_URI . 'li') { |
439 |
|
|
$xuri = $RDF_URI . '_' . ${$opt{li_counter}}++; |
440 |
|
|
} |
441 |
|
|
|
442 |
|
|
if ({ |
443 |
|
|
%coreSyntaxTerms, |
444 |
|
|
$RDF_URI . 'Description' => 1, |
445 |
|
|
%oldTerms, |
446 |
|
|
}->{$xuri}) { |
447 |
|
|
$self->{onerror}->(type => 'element not allowed', |
448 |
|
|
level => $self->{grammer_level}, |
449 |
|
|
node => $node); |
450 |
|
|
## TODO: RDF Validator? |
451 |
|
|
} |
452 |
|
|
|
453 |
wakaba |
1.6 |
my $rdf_id_attr; |
454 |
wakaba |
1.1 |
my $dt_attr; |
455 |
|
|
my $parse_attr; |
456 |
|
|
my $nodeid_attr; |
457 |
|
|
my $resource_attr; |
458 |
|
|
my @prop_attr; |
459 |
|
|
for my $attr (@{$node->attributes}) { |
460 |
wakaba |
1.7 |
my $nsuri = $attr->namespace_uri; |
461 |
|
|
if (defined $nsuri and |
462 |
|
|
$nsuri eq q<http://www.w3.org/XML/1998/namespace> and |
463 |
|
|
$attr->manakai_local_name eq 'lang') { |
464 |
|
|
$opt{language} = $attr->value; |
465 |
|
|
} |
466 |
|
|
|
467 |
wakaba |
1.1 |
my $prefix = $attr->prefix; |
468 |
|
|
if (defined $prefix) { |
469 |
|
|
next if $prefix =~ /^[Xx][Mm][Ll]/; |
470 |
|
|
} else { |
471 |
|
|
next if $attr->manakai_local_name =~ /^[Xx][Mm][Ll]/; |
472 |
|
|
} |
473 |
|
|
|
474 |
|
|
$check_rdf_namespace->($self, $attr); |
475 |
|
|
|
476 |
|
|
my $attr_xuri = $attr->manakai_expanded_uri; |
477 |
wakaba |
1.7 |
|
478 |
|
|
unless (defined $nsuri) { |
479 |
|
|
$attr_xuri = $check_local_attr->($self, $node, $attr, $attr_xuri); |
480 |
|
|
} |
481 |
|
|
|
482 |
wakaba |
1.1 |
if ($attr_xuri eq $RDF_URI . 'ID') { |
483 |
wakaba |
1.6 |
$rdf_id_attr = $attr; |
484 |
wakaba |
1.1 |
} elsif ($attr_xuri eq $RDF_URI . 'datatype') { |
485 |
|
|
$dt_attr = $attr; |
486 |
|
|
} elsif ($attr_xuri eq $RDF_URI . 'parseType') { |
487 |
|
|
$parse_attr = $attr; |
488 |
|
|
} elsif ($attr_xuri eq $RDF_URI . 'resource') { |
489 |
|
|
$resource_attr = $attr; |
490 |
|
|
} elsif ($attr_xuri eq $RDF_URI . 'nodeID') { |
491 |
|
|
$nodeid_attr = $attr; |
492 |
|
|
} elsif ({ |
493 |
|
|
%coreSyntaxTerms, |
494 |
|
|
$RDF_URI . 'li' => 1, |
495 |
|
|
$RDF_URI . 'Description' => 1, |
496 |
|
|
%oldTerms, |
497 |
|
|
}->{$attr_xuri}) { |
498 |
|
|
$self->{onerror}->(type => 'attribute not allowed', |
499 |
|
|
level => $self->{grammer_level}, |
500 |
|
|
node => $attr); |
501 |
|
|
## TODO: RDF Validator? |
502 |
|
|
} else { |
503 |
|
|
push @prop_attr, $attr; |
504 |
|
|
} |
505 |
|
|
} |
506 |
|
|
|
507 |
|
|
my $parse = $parse_attr ? $parse_attr->value : ''; |
508 |
|
|
if ($parse eq 'Resource') { |
509 |
|
|
# |parseTypeResourcePropertyElt| |
510 |
|
|
|
511 |
|
|
for my $attr ($resource_attr, $nodeid_attr, $dt_attr) { |
512 |
wakaba |
1.2 |
next unless $attr; |
513 |
wakaba |
1.1 |
$self->{onerror}->(type => 'attribute not allowed', |
514 |
|
|
level => $self->{grammer_level}, |
515 |
|
|
node => $attr); |
516 |
|
|
## TODO: RDF Validator? |
517 |
|
|
} |
518 |
|
|
|
519 |
wakaba |
1.4 |
my $object = {bnodeid => $generate_bnodeid->($self)}; |
520 |
wakaba |
1.1 |
$self->{ontriple}->(subject => $opt{subject}, |
521 |
|
|
predicate => {uri => $xuri}, |
522 |
wakaba |
1.2 |
object => $object, |
523 |
wakaba |
1.3 |
node => $node, |
524 |
wakaba |
1.6 |
id => $get_id_resource->($self, $rdf_id_attr)); |
525 |
wakaba |
1.1 |
|
526 |
|
|
## As if nodeElement |
527 |
|
|
|
528 |
|
|
# |propertyEltList| |
529 |
|
|
|
530 |
|
|
my $li_counter = 1; |
531 |
|
|
for my $cn (@{$node->child_nodes}) { |
532 |
|
|
my $cn_type = $cn->node_type; |
533 |
|
|
if ($cn_type == $cn->ELEMENT_NODE) { |
534 |
|
|
$self->convert_property_element ($cn, li_counter => \$li_counter, |
535 |
wakaba |
1.7 |
subject => $object, |
536 |
|
|
language => $opt{language}); |
537 |
wakaba |
1.1 |
} elsif ($cn_type == $cn->TEXT_NODE or |
538 |
|
|
$cn_type == $cn->CDATA_SECTION_NODE) { |
539 |
|
|
if ($cn->data =~ /[^\x09\x0A\x0D\x20]/) { |
540 |
|
|
$self->{onerror}->(type => 'character not allowed', |
541 |
|
|
level => $self->{grammer_level}, |
542 |
|
|
node => $cn); |
543 |
|
|
} |
544 |
|
|
} |
545 |
|
|
} |
546 |
|
|
} elsif ($parse eq 'Collection') { |
547 |
|
|
# |parseTypeCollectionPropertyElt| |
548 |
|
|
|
549 |
|
|
for my $attr ($resource_attr, $nodeid_attr, $dt_attr) { |
550 |
wakaba |
1.2 |
next unless $attr; |
551 |
wakaba |
1.1 |
$self->{onerror}->(type => 'attribute not allowed', |
552 |
|
|
level => $self->{grammer_level}, |
553 |
|
|
node => $attr); |
554 |
|
|
## TODO: RDF Validator? |
555 |
|
|
} |
556 |
|
|
|
557 |
|
|
# |nodeElementList| |
558 |
|
|
my @resource; |
559 |
|
|
for my $cn (@{$node->child_nodes}) { |
560 |
|
|
if ($cn->node_type == $cn->ELEMENT_NODE) { |
561 |
|
|
push @resource, [$self->convert_node_element ($cn), |
562 |
wakaba |
1.4 |
{bnodeid => $generate_bnodeid->($self)}, |
563 |
wakaba |
1.2 |
$cn]; |
564 |
wakaba |
1.1 |
} elsif ($cn->node_type == $cn->TEXT_NODE or |
565 |
|
|
$cn->node_type == $cn->CDATA_SECTION_NODE) { |
566 |
|
|
if ($cn->data =~ /[^\x09\x0A\x0D\x20]/) { |
567 |
|
|
$self->{onerror}->(type => 'character not allowed', |
568 |
|
|
level => $self->{grammer_level}, |
569 |
|
|
node => $cn); |
570 |
|
|
} |
571 |
|
|
} |
572 |
|
|
} |
573 |
|
|
|
574 |
|
|
if (@resource) { |
575 |
|
|
$self->{ontriple}->(subject => $opt{subject}, |
576 |
|
|
predicate => {uri => $xuri}, |
577 |
wakaba |
1.2 |
object => $resource[0]->[1], |
578 |
|
|
node => $node); |
579 |
wakaba |
1.1 |
} else { |
580 |
|
|
$self->{ontriple}->(subject => $opt{subject}, |
581 |
|
|
predicate => {uri => $xuri}, |
582 |
wakaba |
1.2 |
object => {uri => $RDF_URI . 'nil'}, |
583 |
wakaba |
1.3 |
node => $node, |
584 |
wakaba |
1.6 |
id => $get_id_resource->($self, $rdf_id_attr)); |
585 |
wakaba |
1.1 |
} |
586 |
wakaba |
1.3 |
|
587 |
wakaba |
1.1 |
while (@resource) { |
588 |
|
|
my $resource = shift @resource; |
589 |
|
|
$self->{ontriple}->(subject => $resource->[1], |
590 |
|
|
predicate => {uri => $RDF_URI . 'first'}, |
591 |
wakaba |
1.2 |
object => $resource->[0], |
592 |
|
|
node => $resource->[2]); |
593 |
wakaba |
1.1 |
if (@resource) { |
594 |
|
|
$self->{ontriple}->(subject => $resource->[1], |
595 |
|
|
predicate => {uri => $RDF_URI . 'rest'}, |
596 |
wakaba |
1.2 |
object => $resource[0]->[1], |
597 |
|
|
node => $resource->[2]); |
598 |
wakaba |
1.1 |
} else { |
599 |
|
|
$self->{ontriple}->(subject => $resource->[1], |
600 |
|
|
predicate => {uri => $RDF_URI . 'rest'}, |
601 |
wakaba |
1.2 |
object => {uri => $RDF_URI . 'nil'}, |
602 |
|
|
node => $resource->[2]); |
603 |
wakaba |
1.1 |
} |
604 |
|
|
} |
605 |
|
|
} elsif ($parse_attr) { |
606 |
|
|
# |parseTypeLiteralPropertyElt| |
607 |
wakaba |
1.5 |
|
608 |
|
|
if ($parse ne 'Literal') { |
609 |
|
|
# |parseTypeOtherPropertyElt| ## TODO: What RDF Validator does? |
610 |
|
|
|
611 |
|
|
$self->{onerror}->(type => 'parse type other', |
612 |
|
|
level => $self->{info_level}, |
613 |
|
|
node => $parse_attr); |
614 |
|
|
} |
615 |
wakaba |
1.1 |
|
616 |
|
|
for my $attr ($resource_attr, $nodeid_attr, $dt_attr) { |
617 |
wakaba |
1.2 |
next unless $attr; |
618 |
wakaba |
1.1 |
$self->{onerror}->(type => 'attribute not allowed', |
619 |
|
|
level => $self->{grammer_level}, |
620 |
|
|
node => $attr); |
621 |
|
|
## TODO: RDF Validator? |
622 |
|
|
} |
623 |
|
|
|
624 |
|
|
my $value = [@{$node->child_nodes}]; |
625 |
|
|
## TODO: Callback for validation |
626 |
|
|
## TODO: Serialized form SHOULD be in NFC. |
627 |
|
|
|
628 |
|
|
$self->{ontriple}->(subject => $opt{subject}, |
629 |
|
|
predicate => {uri => $xuri}, |
630 |
|
|
object => {nodes => $value, |
631 |
wakaba |
1.2 |
datatype => $RDF_URI . 'XMLLiteral'}, |
632 |
wakaba |
1.3 |
node => $node, |
633 |
wakaba |
1.6 |
id => $get_id_resource->($self, $rdf_id_attr)); |
634 |
wakaba |
1.1 |
} else { |
635 |
|
|
my $mode = 'unknown'; |
636 |
|
|
|
637 |
|
|
if ($dt_attr) { |
638 |
|
|
$mode = 'literal'; # |literalPropertyElt| |
639 |
|
|
## TODO: What RDF Validator does for |< rdf:datatype><el/></>|? |
640 |
|
|
} |
641 |
|
|
## TODO: What RDF Validator does for |< prop-attr><non-empty/></>|? |
642 |
|
|
|
643 |
|
|
my $node_element; |
644 |
|
|
my $text = ''; |
645 |
|
|
for my $cn (@{$node->child_nodes}) { |
646 |
|
|
my $cn_type = $cn->node_type; |
647 |
|
|
if ($cn_type == $cn->ELEMENT_NODE) { |
648 |
|
|
unless ($node_element) { |
649 |
|
|
$node_element = $cn; |
650 |
|
|
if ({ |
651 |
|
|
resource => 1, unknown => 1, 'literal-or-resource' => 1, |
652 |
|
|
}->{$mode}) { |
653 |
|
|
$mode = 'resource'; |
654 |
|
|
} else { |
655 |
|
|
$self->{onerror}->(type => 'element not allowed', |
656 |
|
|
level => $self->{grammer_level}, |
657 |
|
|
node => $cn); |
658 |
|
|
## TODO: RDF Validator? |
659 |
|
|
} |
660 |
|
|
} else { |
661 |
|
|
## TODO: What RDF Validator does? |
662 |
|
|
$self->{onerror}->(type => 'second node element', |
663 |
|
|
level => $self->{grammer_level}, |
664 |
|
|
node => $cn); |
665 |
|
|
} |
666 |
|
|
} elsif ($cn_type == $cn->TEXT_NODE or |
667 |
|
|
$cn_type == $cn->CDATA_SECTION_NODE) { |
668 |
|
|
my $data = $cn->data; |
669 |
|
|
$text .= $data; |
670 |
|
|
if ($data =~ /[^\x09\x0A\x0D\x20]/) { |
671 |
|
|
if ({ |
672 |
|
|
literal => 1, unknown => 1, 'literal-or-resource' => 1, |
673 |
|
|
}->{$mode}) { |
674 |
|
|
$mode = 'literal'; |
675 |
|
|
} else { |
676 |
|
|
$self->{onerror}->(type => 'character not allowed', |
677 |
|
|
level => $self->{grammer_level}, |
678 |
|
|
node => $cn); |
679 |
|
|
## TODO: RDF Validator? |
680 |
|
|
} |
681 |
|
|
} else { |
682 |
|
|
if ($mode eq 'unknown') { |
683 |
|
|
$mode = 'literal-or-resource'; |
684 |
|
|
} else { |
685 |
|
|
# |
686 |
|
|
} |
687 |
|
|
} |
688 |
|
|
} |
689 |
|
|
} |
690 |
|
|
|
691 |
|
|
if ($mode eq 'resource') { |
692 |
|
|
# |resourcePropertyElt| |
693 |
|
|
|
694 |
|
|
for my $attr (@prop_attr, $resource_attr, $nodeid_attr, $dt_attr) { |
695 |
wakaba |
1.2 |
next unless $attr; |
696 |
wakaba |
1.1 |
$self->{onerror}->(type => 'attribute not allowed', |
697 |
|
|
level => $self->{grammer_level}, |
698 |
|
|
node => $attr); |
699 |
|
|
## TODO: RDF Validator? |
700 |
|
|
} |
701 |
|
|
|
702 |
wakaba |
1.7 |
my $object = $self->convert_node_element ($node_element, |
703 |
|
|
language => $opt{language}); |
704 |
wakaba |
1.1 |
|
705 |
|
|
$self->{ontriple}->(subject => $opt{subject}, |
706 |
|
|
predicate => {uri => $xuri}, |
707 |
wakaba |
1.2 |
object => $object, |
708 |
wakaba |
1.3 |
node => $node, |
709 |
wakaba |
1.6 |
id => $get_id_resource->($self, $rdf_id_attr)); |
710 |
wakaba |
1.1 |
} elsif ($mode eq 'literal' or $mode eq 'literal-or-resource') { |
711 |
|
|
# |literalPropertyElt| |
712 |
|
|
|
713 |
|
|
for my $attr (@prop_attr, $resource_attr, $nodeid_attr) { |
714 |
wakaba |
1.2 |
next unless $attr; |
715 |
wakaba |
1.1 |
$self->{onerror}->(type => 'attribute not allowed', |
716 |
|
|
level => $self->{grammer_level}, |
717 |
|
|
node => $attr); |
718 |
|
|
## TODO: RDF Validator? |
719 |
|
|
} |
720 |
|
|
|
721 |
|
|
## TODO: $text SHOULD be in NFC |
722 |
|
|
|
723 |
|
|
if ($dt_attr) { |
724 |
wakaba |
1.5 |
$self->{ontriple} |
725 |
|
|
->(subject => $opt{subject}, |
726 |
|
|
predicate => {uri => $xuri}, |
727 |
|
|
object => {value => $text, |
728 |
|
|
datatype => $uri_attr->$self, ($dt_attr->value)}, |
729 |
|
|
## ISSUE: No resolve() in the spec (but spec says that |
730 |
|
|
## xml:base is applied also to rdf:datatype). |
731 |
|
|
node => $node, |
732 |
wakaba |
1.6 |
id => $get_id_resource->($self, $rdf_id_attr)); |
733 |
wakaba |
1.1 |
} else { |
734 |
|
|
$self->{ontriple}->(subject => $opt{subject}, |
735 |
|
|
predicate => {uri => $xuri}, |
736 |
|
|
object => {value => $text, |
737 |
wakaba |
1.7 |
language => $opt{language}}, |
738 |
wakaba |
1.3 |
node => $node, |
739 |
wakaba |
1.6 |
id => $get_id_resource->($self, $rdf_id_attr)); |
740 |
wakaba |
1.1 |
} |
741 |
|
|
} else { |
742 |
|
|
## |emptyPropertyElt| |
743 |
|
|
|
744 |
|
|
for my $attr ($dt_attr) { |
745 |
wakaba |
1.2 |
next unless $attr; |
746 |
wakaba |
1.1 |
$self->{onerror}->(type => 'attribute not allowed', |
747 |
|
|
level => $self->{grammer_level}, |
748 |
|
|
node => $attr); |
749 |
|
|
## TODO: RDF Validator? |
750 |
|
|
} |
751 |
|
|
|
752 |
|
|
if (not $resource_attr and not $nodeid_attr and not @prop_attr) { |
753 |
|
|
$self->{ontriple}->(subject => $opt{subject}, |
754 |
|
|
predicate => {uri => $xuri}, |
755 |
|
|
object => {value => '', |
756 |
wakaba |
1.7 |
language => $opt{language}}, |
757 |
wakaba |
1.3 |
node => $node, |
758 |
wakaba |
1.6 |
id => $get_id_resource->($self, $rdf_id_attr)); |
759 |
wakaba |
1.1 |
} else { |
760 |
|
|
my $object; |
761 |
|
|
if ($resource_attr) { |
762 |
wakaba |
1.5 |
$object = {uri => $uri_attr->($self, $resource_attr)}; |
763 |
|
|
if (defined $nodeid_attr) { |
764 |
|
|
$self->{onerror}->(type => 'attribute not allowed', |
765 |
|
|
level => $self->{grammer_level}, |
766 |
|
|
node => $nodeid_attr); |
767 |
|
|
## TODO: RDF Validator? |
768 |
|
|
} |
769 |
wakaba |
1.1 |
} elsif ($nodeid_attr) { |
770 |
wakaba |
1.5 |
my $id = $nodeid_attr->value; |
771 |
|
|
unless ($id =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) { |
772 |
|
|
$self->{onerror}->(type => 'syntax error', ## TODO: type |
773 |
|
|
level => $self->{grammer_level}, |
774 |
|
|
node => $self); |
775 |
|
|
} |
776 |
|
|
$object = {bnodeid => $get_bnodeid->($id)}; |
777 |
wakaba |
1.1 |
} else { |
778 |
wakaba |
1.4 |
$object = {bnodeid => $generate_bnodeid->($self)}; |
779 |
wakaba |
1.1 |
} |
780 |
|
|
|
781 |
|
|
for my $attr (@prop_attr) { |
782 |
|
|
my $attr_xuri = $attr->manakai_expanded_uri; |
783 |
|
|
if ($attr_xuri eq $RDF_URI . 'type') { |
784 |
|
|
$self->{ontriple}->(subject => $object, |
785 |
|
|
predicate => {uri => $attr_xuri}, |
786 |
wakaba |
1.4 |
object => $resolve->($attr->value, $attr), |
787 |
wakaba |
1.2 |
node => $attr); |
788 |
wakaba |
1.1 |
} else { |
789 |
|
|
## TODO: SHOULD be in NFC |
790 |
|
|
$self->{ontriple}->(subject => $object, |
791 |
|
|
predicate => {uri => $attr_xuri}, |
792 |
|
|
object => {value => $attr->value, |
793 |
wakaba |
1.7 |
language => $opt{language}}, |
794 |
wakaba |
1.2 |
node => $attr); |
795 |
wakaba |
1.1 |
} |
796 |
|
|
} |
797 |
|
|
|
798 |
|
|
$self->{ontriple}->(subject => $opt{subject}, |
799 |
|
|
predicate => {uri => $xuri}, |
800 |
wakaba |
1.2 |
object => $object, |
801 |
wakaba |
1.3 |
node => $node, |
802 |
wakaba |
1.6 |
id => $get_id_resource->($self, $rdf_id_attr)); |
803 |
wakaba |
1.1 |
} |
804 |
|
|
} |
805 |
|
|
} |
806 |
|
|
} # convert_property_element |
807 |
|
|
|
808 |
|
|
1; |
809 |
|
|
|