File Coverage

blib/lib/RDF/Trine/Parser/RDFXML.pm
Criterion Covered Total %
statement 564 616 91.5
branch 153 198 77.2
condition 35 58 60.3
subroutine 59 59 100.0
pod 4 4 100.0
total 815 935 87.1


line stmt bran cond sub pod time code
1             # RDF::Trine::Parser::RDFXML
2             # -----------------------------------------------------------------------------
3              
4             =head1 NAME
5              
6             RDF::Trine::Parser::RDFXML - RDF/XML Parser
7              
8             =head1 VERSION
9              
10             This document describes RDF::Trine::Parser::RDFXML version 1.018
11              
12             =head1 SYNOPSIS
13              
14             use RDF::Trine::Parser;
15             my $parser = RDF::Trine::Parser->new( 'rdfxml' );
16             $parser->parse_into_model( $base_uri, $data, $model );
17              
18             =head1 DESCRIPTION
19              
20             ...
21              
22             =head1 METHODS
23              
24             Beyond the methods documented below, this class inherits methods from the
25             L<RDF::Trine::Parser> class.
26              
27             =over 4
28              
29             =cut
30              
31             package RDF::Trine::Parser::RDFXML;
32              
33 68     68   402 use strict;
  68         161  
  68         1634  
34 68     68   364 use warnings;
  68         144  
  68         1646  
35              
36 68     68   329 use base qw(RDF::Trine::Parser);
  68         145  
  68         3885  
37              
38 68     68   409 use URI;
  68         148  
  68         1217  
39 68     68   307 use Carp;
  68         164  
  68         3030  
40 68     68   391 use Encode;
  68         155  
  68         4573  
41 68     68   394 use XML::SAX;
  68         159  
  68         2115  
42 68     68   359 use Data::Dumper;
  68         153  
  68         2221  
43 68     68   364 use Log::Log4perl;
  68         161  
  68         428  
44 68     68   3640 use Scalar::Util qw(blessed);
  68         162  
  68         2634  
45 68     68   425 use Module::Load::Conditional qw[can_load];
  68         158  
  68         2427  
46              
47 68     68   382 use RDF::Trine qw(literal);
  68         168  
  68         2089  
48 68     68   350 use RDF::Trine::Node;
  68         140  
  68         1792  
49 68     68   354 use RDF::Trine::Statement;
  68         139  
  68         1340  
50 68     68   349 use RDF::Trine::Error qw(:try);
  68         141  
  68         386  
51              
52             ######################################################################
53              
54             our ($VERSION, $HAS_XML_LIBXML);
55             BEGIN {
56 68     68   13938 $VERSION = '1.018';
57 68         182 $RDF::Trine::Parser::parser_names{ 'rdfxml' } = __PACKAGE__;
58 68         173 foreach my $ext (qw(rdf xrdf rdfx)) {
59 204         488 $RDF::Trine::Parser::file_extensions{ $ext } = __PACKAGE__;
60             }
61 68         216 my $class = __PACKAGE__;
62 68         164 $RDF::Trine::Parser::canonical_media_types{ $class } = 'application/rdf+xml';
63 68         198 foreach my $type (qw(application/rdf+xml application/octet-stream)) {
64 136         305 $RDF::Trine::Parser::media_types{ $type } = __PACKAGE__;
65             }
66 68         168 $RDF::Trine::Parser::format_uris{ 'http://www.w3.org/ns/formats/RDF_XML' } = __PACKAGE__;
67            
68 68         412 $HAS_XML_LIBXML = can_load( modules => {
69             'XML::LibXML' => 1.70,
70             } );
71              
72             }
73              
74             ######################################################################
75              
76             =item C<< new >>
77              
78             =cut
79              
80             sub new {
81 263     263 1 86549 my $class = shift;
82 263         914 my %args = @_;
83 263   33     1454 $class = ref($class) || $class;
84              
85 263         608 my $prefix = '';
86 263 100       875 if (defined($args{ BNodePrefix })) {
    50          
87 256         662 $prefix = delete $args{ BNodePrefix };
88             } elsif (defined($args{ bnode_prefix })) {
89 0         0 $prefix = delete $args{ bnode_prefix };
90             } else {
91 7         53 $prefix = $class->new_bnode_prefix();
92             }
93            
94 263         1847 my $saxhandler = RDF::Trine::Parser::RDFXML::SAXHandler->new( %args, bnode_prefix => $prefix );
95 263         2244 my $p = XML::SAX::ParserFactory->parser(Handler => $saxhandler);
96            
97 263         225439 my $self = bless( {
98             saxhandler => $saxhandler,
99             parser => $p,
100             %args,
101             }, $class);
102 263         905 return $self;
103             }
104              
105             =item C<< parse_into_model ( $base_uri, $data, $model [, context => $context] ) >>
106              
107             Parses the bytes in C<< $data >>, using the given C<< $base_uri >>. For each RDF
108             statement parsed, will call C<< $model->add_statement( $statement ) >>.
109              
110             =cut
111              
112             sub parse_into_model {
113 136     136 1 2272 my $proto = shift;
114 136 50       542 my $self = blessed($proto) ? $proto : $proto->new();
115 136         306 my $uri = shift;
116 136 50 33     570 if (blessed($uri) and $uri->isa('RDF::Trine::Node::Resource')) {
117 0         0 $uri = $uri->uri_value;
118             }
119 136         304 my $input = shift;
120 136         278 my $model = shift;
121 136         340 my %args = @_;
122 136         311 my $context = $args{'context'};
123            
124             my $handler = sub {
125 242     242   443 my $st = shift;
126 242 50       644 if ($context) {
127 0         0 my $quad = RDF::Trine::Statement::Quad->new( $st->nodes, $context );
128 0         0 $model->add_statement( $quad );
129             } else {
130 242         898 $model->add_statement( $st );
131             }
132 136         616 };
133 136         936 $self->{saxhandler}->set_handler( $handler );
134 136         447 return $self->parse( $uri, $input, $handler );
135             }
136              
137             =item C<< parse ( $base_uri, $rdf, \&handler ) >>
138              
139             =cut
140              
141             sub parse {
142 136     136 1 279 my $self = shift;
143 136         270 my $base = shift;
144 136         251 my $string = shift;
145 136         265 my $handler = shift;
146 136 100       347 unless ($string) {
147 4         27 throw RDF::Trine::Error::ParserError -text => "No RDF/XML content supplied to parser.";
148             }
149 132 50       391 if ($base) {
150 132 50       534 unless (blessed($base)) {
151 132         854 $base = RDF::Trine::Node::Resource->new( $base );
152             }
153 132         491 $self->{saxhandler}->push_base( $base );
154             }
155            
156 132 50       384 if ($handler) {
157 132         477 $self->{saxhandler}->set_handler( $handler );
158             }
159            
160 132         276 eval {
161 132 50       354 if (ref($string)) {
162 0         0 $self->{parser}->parse_file( $string );
163             } else {
164 132         625 $string = encode('UTF-8', $string, Encode::FB_CROAK);
165 132         8664 $self->{parser}->parse_string( $string );
166             }
167             };
168 132 50       30350 if ($@) {
169 0         0 throw RDF::Trine::Error::ParserError -text => "$@";
170             }
171            
172 132         383 my $nodes = $self->{saxhandler}{nodes};
173 132 50 50     799 if ($nodes and scalar(@$nodes)) {
174 0         0 warn Dumper($nodes);
175 0         0 throw RDF::Trine::Error::ParserError -text => "node stack isn't empty after parse";
176             }
177 132         332 my $expect = $self->{saxhandler}{expect};
178 132 50 33     1040 if ($expect and scalar(@$expect) > 2) {
179 0         0 warn Dumper($expect);
180 0         0 throw RDF::Trine::Error::ParserError -text => "expect stack isn't empty after parse";
181             }
182             }
183              
184             =item C<< parse_file ( $base_uri, $fh, \&handler ) >>
185              
186             Parses all data read from the filehandle C<< $fh >>, using the given
187             C<< $base_uri >>. For each RDF statement parsed, C<< $handler->( $st ) >> is called.
188              
189             Note: The filehandle should NOT be opened with the ":encoding(UTF-8)" IO layer,
190             as this is known to cause problems for XML::SAX.
191              
192             =cut
193              
194             sub parse_file {
195 130     130 1 297 my $self = shift;
196 130         279 my $base = shift;
197 130         296 my $fh = shift;
198 130         268 my $handler = shift;
199            
200 130 50       377 unless (ref($fh)) {
201 130         232 my $filename = $fh;
202 130         277 undef $fh;
203 130 50       5487 open( $fh, '<', $filename ) or throw RDF::Trine::Error::ParserError -text => $!;
204             }
205 130 100       464 if ($base) {
206 128 50       462 unless (blessed($base)) {
207 128         889 $base = RDF::Trine::Node::Resource->new( $base );
208             }
209 128         531 $self->{saxhandler}->push_base( $base );
210             }
211            
212 130 50       444 if ($handler) {
213 130         606 $self->{saxhandler}->set_handler( $handler );
214             }
215            
216 130         310 eval {
217 130         618 $self->{parser}->parse_file( $fh );
218             };
219 130 50       32025 if ($@) {
220 0         0 throw RDF::Trine::Error::ParserError -text => "$@";
221             }
222            
223 130         367 my $nodes = $self->{saxhandler}{nodes};
224 130 50 50     828 if ($nodes and scalar(@$nodes)) {
225 0         0 warn Dumper($nodes);
226 0         0 throw RDF::Trine::Error::ParserError -text => "node stack isn't empty after parse";
227             }
228 130         305 my $expect = $self->{saxhandler}{expect};
229 130 50 33     4893 if ($expect and scalar(@$expect) > 2) {
230 0         0 warn Dumper($expect);
231 0         0 throw RDF::Trine::Error::ParserError -text => "expect stack isn't empty after parse";
232             }
233             }
234              
235              
236             package RDF::Trine::Parser::RDFXML::SAXHandler;
237              
238 68     68   78561 use strict;
  68         182  
  68         1462  
239 68     68   342 use warnings;
  68         141  
  68         2054  
240 68     68   366 use base qw(XML::SAX::Base);
  68         171  
  68         4392  
241              
242 68     68   418 use Data::Dumper;
  68         170  
  68         2835  
243 68     68   403 use Scalar::Util qw(blessed);
  68         158  
  68         2666  
244 68     68   1799 use RDF::Trine::Namespace qw(rdf);
  68         168  
  68         552  
245              
246 68     68   399 use constant NIL => 0x00;
  68         159  
  68         4116  
247 68     68   836 use constant SUBJECT => 0x01;
  68         149  
  68         2805  
248 68     68   356 use constant PREDICATE => 0x02;
  68         155  
  68         2614  
249 68     68   352 use constant OBJECT => 0x04;
  68         151  
  68         2495  
250 68     68   368 use constant LITERAL => 0x08;
  68         149  
  68         2427  
251 68     68   353 use constant COLLECTION => 0x16;
  68         150  
  68         226599  
252              
253             sub new {
254 263     263   575 my $class = shift;
255 263         780 my %args = @_;
256 263         546 my $prefix = '';
257 263 50       1140 if (defined($args{ BNodePrefix })) {
    50          
258 0         0 $prefix = $args{ BNodePrefix };
259             } elsif (defined($args{ bnode_prefix })) {
260 263         547 $prefix = $args{ bnode_prefix };
261             }
262 263         2202 my $self = bless( {
263             expect => [ SUBJECT, NIL ],
264             base => [],
265             depth => 0,
266             characters => '',
267             prefix => $prefix,
268             counter => 0,
269             nodes => [],
270             chars_ok => 0,
271             }, $class );
272 263 100       865 if (my $ns = $args{ namespaces }) {
273 1         14 $self->{namespaces} = $ns;
274             }
275 263 50       727 if (my $base = $args{ base }) {
276 0         0 $self->push_base( $base );
277             }
278 263         727 return $self;
279             }
280              
281             sub new_expect {
282 525     525   895 my $self = shift;
283 525         984 my $new = shift;
284 525         814 unshift( @{ $self->{expect} }, $new );
  525         1431  
285             }
286              
287             sub old_expect {
288 785     785   1193 my $self = shift;
289 785         1240 shift( @{ $self->{expect} } );
  785         1527  
290             }
291              
292             sub expect {
293 5039     5039   7895 my $self = shift;
294 5039 50       7174 if (scalar(@{ $self->{expect} }) == 0) {
  5039         12922  
295 0         0 Carp::cluck '********* expect stack is empty';
296             }
297 5039         11905 return $self->{expect}[0];
298             }
299              
300             sub peek_expect {
301 288     288   617 my $self = shift;
302 288         1201 return $self->{expect}[1];
303             }
304              
305              
306             =begin private
307              
308             =item C<< start_element >>
309              
310             =cut
311              
312             sub start_element {
313 807     807   686220 my $self = shift;
314 807         1546 my $el = shift;
315 807         3783 my $l = Log::Log4perl->get_logger("rdf.trine.parser.rdfxml");
316            
317 807         27398 $l->trace('start_element ' . $el->{Name});
318            
319 807         7197 $self->{depth}++;
320 807 100       2249 unless ($self->expect == LITERAL) {
321 783         2088 $self->handle_scoped_values( $el );
322             }
323 807 100 100     4534 if ($self->{depth} == 1 and $el->{NamespaceURI} eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#' and $el->{LocalName} eq 'RDF') {
      66        
324             # ignore the wrapping rdf:RDF element
325             } else {
326 547         1052 my $prefix = $el->{Prefix};
327 547         1112 my $expect = $self->expect;
328            
329 547 50       1376 if ($expect == NIL) {
330 0         0 $self->new_expect( $expect = SUBJECT );
331             }
332            
333 547 100 100     2598 if ($expect == SUBJECT or $expect == OBJECT) {
    50          
    100          
    50          
334 288         828 my $ns = $self->get_namespace( $prefix );
335 288         650 my $local = $el->{LocalName};
336 288         799 my $uri = join('', $ns, $local);
337 288         791 my $node = $self->new_resource( $uri );
338 288         1270 $l->trace("-> expect SUBJECT or OBJECT");
339 288 100       2935 if ($self->expect == OBJECT) {
340 8 100 100     51 if (defined($self->{characters}) and length(my $string = $self->{characters})) {
341 4 50       18 if ($string =~ /\S/) {
342 0         0 die "character data found before object element";
343             }
344             }
345 8         18 delete($self->{characters}); # get rid of any whitespace we saw before the element
346             }
347 288         1046 my $node_id = $self->node_id( $el );
348            
349 288 100       934 if ($self->peek_expect == COLLECTION) {
    100          
350 4         11 my $list = $self->new_bnode;
351 4         14 $l->trace("adding an OBJECT to a COLLECTION " . $list->sse . "\n");
352 4 100       45 if (my $last = $self->{ collection_last }[0]) {
353 2         18 my $st = RDF::Trine::Statement->new( $last, $rdf->rest, $list );
354 2         7 $self->assert( $st );
355             }
356 4         10 $self->{ collection_last }[0] = $list;
357 4         35 my $st = RDF::Trine::Statement->new( $list, $rdf->first, $node_id );
358 4         14 $self->assert( $st );
359 4   66     20 $self->{ collection_head }[0] ||= $list;
360             } elsif ($self->expect == OBJECT) {
361 4         9 my $nodes = $self->{nodes};
362 4         9 my $st = RDF::Trine::Statement->new( @{ $nodes }[ $#{$nodes} - 1, $#{$nodes} ], $node_id );
  4         23  
  4         10  
  4         9  
363 4         14 $self->assert( $st );
364             }
365            
366 288 100       880 if ($uri eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#Description') {
367 202         786 $l->trace("got rdf:Description of " . $node_id->as_string);
368             } else {
369 86         175 my $type = $node;
370 86         307 $l->trace("got object node " . $node_id->as_string . " of type " . $node->as_string);
371             # emit an rdf:type statement
372 86         1372 my $st = RDF::Trine::Statement->new( $node_id, $rdf->type, $node );
373 86         302 $self->assert( $st );
374             }
375 288         2042 push( @{ $self->{nodes} }, $node_id );
  288         845  
376            
377 288         1004 $self->parse_literal_property_attributes( $el, $node_id );
378 288         966 $self->new_expect( PREDICATE );
379 288         497 unshift(@{ $self->{seqs} }, 0);
  288         772  
380 288         1248 $l->trace('unshifting seq counter: ' . Dumper($self->{seqs}));
381             } elsif ($self->expect == COLLECTION) {
382 0         0 $l->logdie("-> expect COLLECTION");
383             } elsif ($self->expect == PREDICATE) {
384 235         569 my $ns = $self->get_namespace( $prefix );
385 235         522 my $local = $el->{LocalName};
386 235         705 my $uri = join('', $ns, $local);
387 235         617 my $node = $self->new_resource( $uri );
388 235         956 $l->trace("-> expect PREDICATE");
389            
390 235 100       2341 if ($node->uri_value eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#li') {
391 44         84 my $id = ++(${ $self }{seqs}[0]);
  44         109  
392 44         148 $node = $self->new_resource( 'http://www.w3.org/1999/02/22-rdf-syntax-ns#_' . $id );
393             }
394            
395 235         554 push( @{ $self->{nodes} }, $node );
  235         674  
396            
397 235 100       844 if (my $data = $el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}datatype'}) {
398 12         32 $self->{datatype} = $data->{Value};
399             }
400            
401 235 100       707 if (my $data = $el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}ID'}) {
402 22         59 my $id = $data->{Value};
403 22         35 unshift(@{ $self->{reify_id} }, $id);
  22         64  
404             } else {
405 213         330 unshift(@{ $self->{reify_id} }, undef);
  213         459  
406             }
407            
408 235 100       1182 if (my $pt = $el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}parseType'}) {
    100          
    100          
    100          
409 34 100       158 if ($pt->{Value} eq 'Resource') {
    100          
    50          
410             # fake an enclosing object scope
411 14         43 my $node = $self->new_bnode;
412 14         38 my $nodes = $self->{nodes};
413 14         28 push( @$nodes, $node );
414 14         32 my $st = RDF::Trine::Statement->new( @{ $nodes }[ $#{$nodes} - 2 .. $#{$nodes} ] );
  14         111  
  14         41  
  14         36  
415 14         55 $self->assert( $st );
416            
417 14         47 $self->new_expect( PREDICATE );
418             } elsif ($pt->{Value} eq 'Literal') {
419 18         55 $self->{datatype} = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#XMLLiteral';
420 18         42 my $depth = $self->{depth};
421 18         74 $self->{literal_depth} = $depth - 1;
422 18         60 $self->new_expect( LITERAL );
423             } elsif ($pt->{Value} eq 'Collection') {
424 2         5 my $depth = $self->{depth};
425            
426 2         3 unshift( @{ $self->{ collection_head } }, undef );
  2         5  
427 2         4 unshift( @{ $self->{ collection_last } }, undef );
  2         9  
428 2         8 $self->new_expect( COLLECTION );
429 2         5 $self->new_expect( OBJECT );
430             }
431             } elsif (my $data = $el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}resource'}) {
432             # stash the uri away so that we can use it when we get the end_element call for this predicate
433 69         218 my $uri = $self->new_resource( $data->{Value} );
434 69         257 $self->parse_literal_property_attributes( $el, $uri );
435 69         171 $self->{'rdf:resource'} = $uri;
436 69         216 $self->new_expect( OBJECT );
437 69         275 $self->{chars_ok} = 1;
438             } elsif (my $ndata = $el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}nodeID'}) {
439 10         27 my $node_name = $ndata->{Value};
440             # stash the bnode away so that we can use it when we get the end_element call for this predicate
441 10         27 my $bnode = $self->get_named_bnode( $node_name );
442 10         37 $self->parse_literal_property_attributes( $el, $uri );
443 10         31 $self->{'rdf:resource'} = $bnode; # the key 'rdf:resource' is a bit misused here, but both rdf:resource and rdf:nodeID use it for the same purpose, so...
444 10         32 $self->new_expect( OBJECT );
445 10         41 $self->{chars_ok} = 1;
446             } elsif (my $node = $self->parse_literal_property_attributes( $el )) {
447             # fake an enclosing object scope
448 10         29 my $nodes = $self->{nodes};
449 10         23 push( @$nodes, $node );
450 10         28 my $st = RDF::Trine::Statement->new( @{ $nodes }[ $#{$nodes} - 2 .. $#{$nodes} ] );
  10         41  
  10         25  
  10         25  
451 10         36 $self->assert( $st );
452            
453 10         34 $self->new_expect( PREDICATE );
454             } else {
455 112         401 $self->new_expect( OBJECT );
456 112         471 $self->{chars_ok} = 1;
457             }
458             } elsif ($self->expect == LITERAL) {
459 24         39 my $tag;
460 24 100       53 if ($el->{Prefix}) {
461 4         10 $tag = join(':', @{ $el }{qw(Prefix LocalName)});
  4         10  
462             } else {
463 20         36 $tag = $el->{LocalName};
464             }
465 24         57 $self->{characters} .= '<' . $tag;
466 24         44 my $attr = $el->{Attributes};
467            
468 24 100       61 if (my $ns = $el->{NamespaceURI}) {
469 22         40 my $abbr = $el->{Prefix};
470 22 100       70 unless ($self->{defined_literal_namespaces}{$abbr}{$ns}) {
471 10         16 $self->{characters} .= ' xmlns';
472 10 100       28 if (length($abbr)) {
473 4         10 $self->{characters} .= ':' . $abbr;
474             }
475 10         27 $self->{characters} .= '="' . $ns . '"';
476 10         30 $self->{defined_literal_namespaces}{$abbr}{$ns}++;
477             }
478             }
479 24 50       63 if (%$attr) {
480 0         0 foreach my $k (keys %$attr) {
481 0         0 $self->{characters} .= ' ';
482 0         0 my $el = $attr->{ $k };
483 0         0 my $prop;
484 0 0       0 if ($el->{Prefix}) {
485 0         0 $prop = join(':', @{ $el }{qw(Prefix LocalName)});
  0         0  
486             } else {
487 0         0 $prop = $el->{LocalName};
488             }
489 0         0 $self->{characters} .= $prop . '="' . $el->{Value} . '"';
490             }
491             }
492 24         69 $self->{characters} .= '>';
493             } else {
494 0         0 die "not sure what type of token is expected";
495             }
496             # warn "GOT: $uri\n";
497            
498             # warn 'start_element: ' . Dumper($el);
499             # warn 'namespaces: ' . Dumper($self->{_namespaces});
500             }
501             }
502              
503             =item C<< end_element >>
504              
505             =cut
506              
507             sub end_element {
508 807     807   94538 my $self = shift;
509 807         1520 my $el = shift;
510 807         1638 $self->{depth}--;
511 807         2703 my $l = Log::Log4perl->get_logger("rdf.trine.parser.rdfxml");
512 807         22247 $l->trace("($self->{depth}) end_element " . $el->{Name});
513            
514 807         6335 my $cleanup = 0;
515 807         2236 my $expect = $self->expect;
516 807 100 66     2832 if ($expect == SUBJECT) {
    100 66        
    100          
    50          
    50          
517 260         791 $l->trace("-> expect SUBJECT");
518 260         2016 $self->old_expect;
519 260         431 $cleanup = 1;
520 260         522 $self->{chars_ok} = 0;
521 260         416 shift(@{ $self->{reify_id} });
  260         594  
522             } elsif ($expect == PREDICATE) {
523 312         1104 $l->trace("-> expect PREDICATE");
524 312         2554 $self->old_expect;
525 312 100       664 if ($self->expect == PREDICATE) {
526             # we're closing a parseType=Resource block, so take off the extra implicit node.
527 24         44 pop( @{ $self->{nodes} } );
  24         59  
528             } else {
529 288         995 $l->trace('shifting seq counter: ' . Dumper($self->{seqs}));
530 288         16228 shift(@{ $self->{seqs} });
  288         610  
531             }
532 312         574 $cleanup = 1;
533 312         685 $self->{chars_ok} = 0;
534             } elsif ($expect == OBJECT or ($expect == LITERAL and $self->{literal_depth} == $self->{depth})) {
535 211 100       571 if (exists $self->{'rdf:resource'}) {
536 79         251 $l->trace("-> predicate used rdf:resource or rdf:nodeID\n");
537 79         590 my $uri = delete $self->{'rdf:resource'};
538 79         175 my $nodes = $self->{nodes};
539 79         138 my $st = RDF::Trine::Statement->new( @{ $nodes }[ $#{$nodes} - 1, $#{$nodes} ], $uri );
  79         479  
  79         211  
  79         151  
540 79         226 delete $self->{characters};
541 79         238 $self->assert( $st );
542             }
543            
544 211         794 $l->trace("-> expect OBJECT");
545 211         1883 $self->old_expect;
546 211 100       646 if (defined($self->{characters})) {
547 126         325 my $string = $self->{characters};
548 126         354 my $literal = $self->new_literal( $string );
549 126         560 $l->trace('node stack: ' . Dumper($self->{nodes}));
550 126         9923 my $nodes = $self->{nodes};
551 126         295 my $st = RDF::Trine::Statement->new( @{ $nodes }[ $#{$nodes} - 1, $#{$nodes} ], $literal );
  126         746  
  126         293  
  126         246  
552 126         503 $self->assert( $st );
553 126         302 delete($self->{characters});
554 126         236 delete $self->{datatype};
555 126         351 delete $self->{defined_literal_namespaces};
556             }
557            
558 211 100       572 if ($self->expect == COLLECTION) {
559             # We were expecting an object, but got an end_element instead.
560             # after poping the OBJECT expectation, we see we were expecting objects in a COLLECTION.
561             # so we're ending the COLLECTION here:
562 2         7 $self->old_expect;
563 2         5 my $nodes = $self->{nodes};
564 2   33     10 my $head = $self->{ collection_head }[0] || $rdf->nil;
565 2         6 my @nodes = (@{ $nodes }[ $#{$nodes} - 1, $#{$nodes} ], $head);
  2         7  
  2         8  
  2         3  
566 2         9 my $st = RDF::Trine::Statement->new( @nodes );
567 2         7 $self->assert( $st );
568            
569 2 50       8 if (my $last = $self->{ collection_last }[0]) {
570 2         12 my @nodes = ( $last, $rdf->rest, $rdf->nil );
571 2         11 my $st = RDF::Trine::Statement->new( @nodes );
572 2         7 $self->assert( $st );
573             }
574            
575 2         5 shift( @{ $self->{ collection_last } } );
  2         5  
576 2         4 shift( @{ $self->{ collection_head } } );
  2         5  
577             }
578            
579 211         378 $cleanup = 1;
580 211         419 $self->{chars_ok} = 0;
581 211         415 shift(@{ $self->{reify_id} });
  211         440  
582             } elsif ($expect == COLLECTION) {
583 0         0 shift( @{ $self->{collections} } );
  0         0  
584 0         0 $self->old_expect;
585 0         0 $l->trace("-> expect COLLECTION");
586             } elsif ($expect == LITERAL) {
587 24         43 my $tag;
588 24 100       53 if ($el->{Prefix}) {
589 4         9 $tag = join(':', @{ $el }{qw(Prefix LocalName)});
  4         10  
590             } else {
591 20         35 $tag = $el->{LocalName};
592             }
593 24         65 $self->{characters} .= '</' . $tag . '>';
594 24         41 $cleanup = 0;
595             } else {
596 0         0 die "how did we get here?";
597             }
598            
599 807 100       2130 if ($cleanup) {
600 783         1171 pop( @{ $self->{nodes} } );
  783         1422  
601 783         2139 $self->pop_namespace_pad();
602 783         2273 $self->pop_language();
603 783         1807 $self->pop_base();
604             }
605             }
606              
607             sub characters {
608 1241     1241   92592 my $self = shift;
609 1241         1963 my $data = shift;
610 1241         3089 my $expect = $self->expect;
611 1241         4146 my $l = Log::Log4perl->get_logger("rdf.trine.parser.rdfxml");
612 1241 100 100     35763 if ($expect == LITERAL or ($expect == OBJECT and $self->{chars_ok})) {
      100        
613 158         776 $l->trace("got character data ($expect): <<$data->{Data}>>\n");
614 158         1394 my $chars = $data->{Data};
615 158         482 $self->{characters} .= $chars;
616             }
617             }
618              
619             sub parse_literal_property_attributes {
620 489     489   961 my $self = shift;
621 489         731 my $el = shift;
622 489   66     1771 my $node_id = shift || $self->new_bnode;
623 72         292 my @keys = grep { not(m<[{][}](xmlns|about)>) }
624 423         2270 grep { not(m<[{]http://www.w3.org/1999/02/22-rdf-syntax-ns#[}](resource|about|ID|datatype|nodeID)>) }
625 433         1483 grep { not(m<[{]http://www.w3.org/XML/1998/namespace[}](base|lang)>) }
626 489         1186 keys %{ $el->{Attributes} };
  489         1517  
627 489         986 my $asserted = 0;
628            
629 489         881 unshift(@{ $self->{reify_id} }, undef); # don't reify any of these triples
  489         1302  
630 489         1117 foreach my $k (@keys) {
631 68         163 my $data = $el->{Attributes}{ $k };
632 68         178 my $ns = $data->{NamespaceURI};
633 68 100       233 unless ($ns) {
634 2         5 my $prefix = $data->{Prefix};
635 2 50       10 next unless (length($ns));
636 0         0 $ns = $self->get_namespace( $prefix );
637             }
638 66 100       205 next if ($ns eq 'http://www.w3.org/XML/1998/namespace');
639 62 100       157 next if ($ns eq 'http://www.w3.org/2000/xmlns/');
640 60         149 my $local = $data->{LocalName};
641 60         176 my $uri = join('', $ns, $local);
642 60         130 my $value = $data->{Value};
643 60         167 my $pred = $self->new_resource( $uri );
644 60 100       198 if ($uri eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#type') {
645             # rdf:type is a special case -- it produces a resource instead of a literal
646 2         6 my $res = $self->new_resource( $value );
647 2         12 my $st = RDF::Trine::Statement->new( $node_id, $pred, $res );
648 2         6 $self->assert( $st );
649             } else {
650 58         195 my $lit = $self->new_literal( $value );
651 58         356 my $st = RDF::Trine::Statement->new( $node_id, $pred, $lit );
652 58         175 $self->assert( $st );
653             }
654 60         175 $asserted++;
655             }
656 489         823 shift(@{ $self->{reify_id} });
  489         952  
657 489 100       1547 return ($asserted ? $node_id : 0);
658             }
659              
660             sub set_handler {
661 398     398   680 my $self = shift;
662 398         732 my $handler = shift;
663 398         938 $self->{sthandler} = $handler;
664             }
665              
666             sub assert {
667 389     389   662 my $self = shift;
668 389         649 my $st = shift;
669 389         1315 my $l = Log::Log4perl->get_logger("rdf.trine.parser.rdfxml");
670 389         10939 $l->debug('[rdfxml parser] ' . $st->as_string);
671            
672 389 50       4112 if ($self->{sthandler}) {
673 389 50       1214 if ($self->{canonicalize}) {
674 0         0 my $o = $st->object;
675 0 0 0     0 if ($o->isa('RDF::Trine::Node::Literal') and $o->has_datatype) {
676 0         0 my $value = $o->literal_value;
677 0         0 my $dt = $o->literal_datatype;
678 0         0 my $canon = RDF::Trine::Node::Literal->canonicalize_literal_value( $value, $dt, 1 );
679 0         0 $o = literal( $canon, undef, $dt );
680 0         0 $st->object( $o );
681             }
682             }
683            
684 389         1243 $self->{sthandler}->( $st );
685 389 100       1774 if (defined(my $id = $self->{reify_id}[0])) {
686 22         95 my $stid = $self->new_resource( "#$id" );
687            
688 22         220 my $tst = RDF::Trine::Statement->new( $stid, $rdf->type, $rdf->Statement );
689 22         114 my $sst = RDF::Trine::Statement->new( $stid, $rdf->subject, $st->subject );
690 22         111 my $pst = RDF::Trine::Statement->new( $stid, $rdf->predicate, $st->predicate );
691 22         117 my $ost = RDF::Trine::Statement->new( $stid, $rdf->object, $st->object );
692 22         65 foreach ($tst, $sst, $pst, $ost) {
693 88         241 $self->{sthandler}->( $_ );
694             }
695 22         101 $self->{reify_id}[0] = undef; # now that we've used this reify ID, get rid of it (because we don't want it used again)
696             }
697             }
698             }
699              
700             sub node_id {
701 288     288   555 my $self = shift;
702 288         517 my $el = shift;
703            
704 288 100       1024 if ($el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}about'}) {
    100          
    100          
705 204         539 my $uri = $el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}about'}{Value};
706 204         573 return $self->new_resource( $uri );
707             } elsif ($el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}ID'}) {
708 30         71 my $uri = $el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}ID'}{Value};
709 30         103 return $self->new_resource( '#' . $uri );
710             } elsif ($el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}nodeID'}) {
711 8         18 my $name = $el->{Attributes}{'{http://www.w3.org/1999/02/22-rdf-syntax-ns#}nodeID'}{Value};
712 8         26 return $self->get_named_bnode( $name );
713             } else {
714 46         161 return $self->new_bnode;
715             }
716             }
717              
718             sub handle_scoped_values {
719 783     783   1182 my $self = shift;
720 783         1174 my $el = shift;
721 783         1214 my %new;
722            
723             {
724             # xml:base
725 783         1450 my $base = '';
726 783 100       1976 if (exists($el->{Attributes}{'{http://www.w3.org/XML/1998/namespace}base'})) {
727 26         49 my $uri = $el->{Attributes}{'{http://www.w3.org/XML/1998/namespace}base'}{Value};
728 26         63 $base = $self->new_resource( $uri );
729             }
730 783         1723 $self->push_base( $base );
731             }
732            
733             {
734             # language
735 783         1289 my $lang = '';
  783         1411  
736 783 100       1983 if (exists($el->{Attributes}{'{http://www.w3.org/XML/1998/namespace}lang'})) {
737 8         23 $lang = $el->{Attributes}{'{http://www.w3.org/XML/1998/namespace}lang'}{Value};
738             }
739 783         2067 $self->push_language( $lang );
740             }
741            
742             {
743             # namespaces
744 783         1306 my @ns = grep { m<^[{]http://www.w3.org/2000/xmlns/[}]> } (keys %{ $el->{Attributes} });
  783         1225  
  783         1308  
  942         3593  
  783         2092  
745 783         2014 foreach my $n (@ns) {
746 434         1077 my ($prefix) = substr($n, 31);
747 434         937 my $value = $el->{Attributes}{$n}{Value};
748 434         897 $new{ $prefix } = $value;
749 434 100       1648 if (blessed(my $ns = $self->{namespaces})) {
750 2 50       9 unless ($ns->namespace_uri($prefix)) {
751 2         8 $ns->add_mapping( $prefix => $value );
752             }
753             }
754             }
755            
756 783 100       2050 if (exists($el->{Attributes}{'{}xmlns'})) {
757 19         45 my $value = $el->{Attributes}{'{}xmlns'}{Value};
758 19         45 $new{ '' } = $value;
759             }
760            
761 783         1964 $self->push_namespace_pad( \%new );
762             }
763             }
764              
765             sub push_base {
766 1043     1043   1710 my $self = shift;
767 1043         1690 my $base = shift;
768 1043 100       2964 if ($base) {
769 286 50 33     3437 my $uri = (blessed($base) and $base->isa('URI')) ? $base : new URI ($base->uri_value );
770 286         20110 $uri->fragment( undef );
771 286         3775 $base = RDF::Trine::Node::Resource->new( "$uri" );
772             }
773 1043         1716 unshift( @{ $self->{base} }, $base );
  1043         3203  
774             }
775              
776             sub pop_base {
777 783     783   1340 my $self = shift;
778 783         1109 shift( @{ $self->{base} } );
  783         2350  
779             }
780              
781             sub get_base {
782 980     980   1536 my $self = shift;
783 980         1449 foreach my $level (0 .. $#{ $self->{base} }) {
  980         2482  
784 3244         5222 my $base = $self->{base}[ $level ];
785 3244 100       8490 if (length($base)) {
786 974         3013 return $base;
787             }
788             }
789 6         12 return ();
790             }
791              
792             sub push_language {
793 783     783   1288 my $self = shift;
794 783         1216 my $lang = shift;
795 783         1179 unshift( @{ $self->{language} }, $lang );
  783         1980  
796             }
797              
798             sub pop_language {
799 783     783   1131 my $self = shift;
800 783         1432 shift( @{ $self->{language} } );
  783         1336  
801             }
802              
803             sub get_language {
804 154     154   268 my $self = shift;
805 154         333 foreach my $level (0 .. $#{ $self->{language} }) {
  154         506  
806 422         725 my $lang = $self->{language}[ $level ];
807 422 100       1023 if (length($lang)) {
808 4         18 return $lang;
809             }
810             }
811 150         521 return '';
812             }
813              
814             sub push_namespace_pad {
815 783     783   1248 my $self = shift;
816 783         1285 my $pad = shift;
817 783         1198 unshift( @{ $self->{_namespaces} }, $pad );
  783         2286  
818             }
819              
820             sub pop_namespace_pad {
821 783     783   1187 my $self = shift;
822 783         1113 shift( @{ $self->{_namespaces} } );
  783         1579  
823             }
824              
825             sub get_namespace {
826 523     523   902 my $self = shift;
827 523         858 my $prefix = shift;
828 523         1072 foreach my $level (0 .. $#{ $self->{_namespaces} }) {
  523         1559  
829 1311         2122 my $pad = $self->{_namespaces}[ $level ];
830 1311 100       3153 if (exists($pad->{ $prefix })) {
831 523         976 my $uri = $pad->{ $prefix };
832 523         1381 return $uri;
833             }
834             }
835 0         0 throw RDF::Trine::Error::ParserError -text => "Unknown namespace: $prefix";
836             }
837              
838             sub new_bnode {
839 196     196   328 my $self = shift;
840 196 100       521 if (my $prefix = $self->{prefix}) {
841 188         547 my $id = $prefix . ++$self->{counter};
842 188         1106 return RDF::Trine::Node::Blank->new( $id );
843             } else {
844 8         51 return RDF::Trine::Node::Blank->new();
845             }
846             }
847              
848             sub new_literal {
849 184     184   337 my $self = shift;
850 184         338 my $string = shift;
851 184         430 my @args = (undef, undef);
852 184 100       626 if (my $dt = $self->{datatype}) { # datatype
    100          
853 30         66 $args[1] = $dt;
854 30 100       97 if ($dt eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#XMLLiteral') {
855 18 50       60 if ($HAS_XML_LIBXML) {
856 0         0 eval {
857 0 0       0 if ($string =~ m/^</) {
858 0         0 my $doc = XML::LibXML->load_xml(string => $string);
859 0         0 my $canon = $doc->toStringEC14N(1);
860 0         0 $string = $canon;
861             }
862             };
863 0 0       0 if ($@) {
864 0         0 warn "Cannot canonicalize XMLLiteral: $@" . Dumper($string);
865             }
866             }
867             }
868             } elsif (my $lang = $self->get_language) {
869 4         10 $args[0] = $lang;
870             }
871 184         1105 my $literal = RDF::Trine::Node::Literal->new( $string, @args );
872             }
873              
874             sub new_resource {
875 980     980   1521 my $self = shift;
876 980         1578 my $uri = shift;
877 980         2358 my @base = $self->get_base;
878 980         3720 my $res = RDF::Trine::Node::Resource->new( $uri, @base );
879 980         2803 return $res;
880             }
881              
882             sub get_named_bnode {
883 18     18   33 my $self = shift;
884 18         28 my $name = shift;
885 18   66     96 return ($self->{named_bnodes}{ $name } ||= $self->new_bnode);
886             }
887              
888             1;
889              
890             __END__
891              
892             =end private
893              
894             =back
895              
896             =head1 BUGS
897              
898             Please report any bugs or feature requests to through the GitHub web interface
899             at L<https://github.com/kasei/perlrdf/issues>.
900              
901             =head1 SEE ALSO
902              
903             L<http://www.w3.org/TR/rdf-syntax-grammar/>
904              
905             =head1 AUTHOR
906              
907             Gregory Todd Williams C<< <gwilliams@cpan.org> >>
908              
909             =head1 COPYRIGHT
910              
911             Copyright (c) 2006-2012 Gregory Todd Williams. This
912             program is free software; you can redistribute it and/or modify it under
913             the same terms as Perl itself.
914              
915             =cut