File Coverage

blib/lib/RDF/Trine/Serializer/RDFXML.pm
Criterion Covered Total %
statement 181 216 83.8
branch 43 54 79.6
condition 2 5 40.0
subroutine 18 20 90.0
pod 3 3 100.0
total 247 298 82.8


line stmt bran cond sub pod time code
1             # RDF::Trine::Serializer::RDFXML
2             # -----------------------------------------------------------------------------
3              
4             =head1 NAME
5              
6             RDF::Trine::Serializer::RDFXML - RDF/XML Serializer
7              
8             =head1 VERSION
9              
10             This document describes RDF::Trine::Serializer::RDFXML version 1.018
11              
12             =head1 SYNOPSIS
13              
14             use RDF::Trine::Serializer::RDFXML;
15             my $serializer = RDF::Trine::Serializer::RDFXML->new( namespaces => { ex => 'http://example/' } );
16             print $serializer->serialize_model_to_string($model);
17              
18             =head1 DESCRIPTION
19              
20             The RDF::Trine::Serializer::Turtle class provides an API for serializing RDF
21             graphs to the RDF/XML syntax.
22              
23             =head1 METHODS
24              
25             Beyond the methods documented below, this class inherits methods from the
26             L<RDF::Trine::Serializer> class.
27              
28             =over 4
29              
30             =cut
31              
32             package RDF::Trine::Serializer::RDFXML;
33              
34 68     68   465 use strict;
  68         165  
  68         1769  
35 68     68   335 use warnings;
  68         151  
  68         1624  
36 68     68   338 use base qw(RDF::Trine::Serializer);
  68         143  
  68         4064  
37              
38 68     68   415 use URI;
  68         144  
  68         1174  
39 68     68   308 use Carp;
  68         144  
  68         3195  
40 68     68   386 use Data::Dumper;
  68         141  
  68         2629  
41 68     68   415 use Scalar::Util qw(blessed);
  68         145  
  68         2735  
42              
43 68     68   379 use RDF::Trine qw(variable);
  68         160  
  68         3165  
44 68     68   397 use RDF::Trine::Statement;
  68         141  
  68         1363  
45 68     68   323 use RDF::Trine::Error qw(:try);
  68         145  
  68         422  
46              
47             ######################################################################
48              
49             our ($VERSION);
50             BEGIN {
51 68     68   10647 $VERSION = '1.018';
52 68         404 $RDF::Trine::Serializer::serializer_names{ 'rdfxml' } = __PACKAGE__;
53 68         152 $RDF::Trine::Serializer::format_uris{ 'http://www.w3.org/ns/formats/RDF_XML' } = __PACKAGE__;
54 68         177 foreach my $type (qw(application/rdf+xml)) {
55 68         101493 $RDF::Trine::Serializer::media_types{ $type } = __PACKAGE__;
56             }
57             }
58              
59             ######################################################################
60              
61             =item C<< new ( namespaces => \%namespaces, base_uri => $baseuri ) >>
62              
63             Returns a new RDF/XML serializer object.
64              
65             =cut
66              
67             sub new {
68 22     22 1 613 my $class = shift;
69 22         57 my %args = @_;
70 22         89 my $self = bless( { namespaces => { 'http://www.w3.org/1999/02/22-rdf-syntax-ns#' => 'rdf' } }, $class);
71 22 100       75 if (my $ns = $args{namespaces}) {
72 4         9 my %nsmap;
73 4 100 66     33 if (blessed($ns) and $ns->isa('RDF::Trine::NamespaceMap')) {
74 1         6 for my $prefix ($ns->list_prefixes) {
75             # way convoluted
76 2         11 my $nsuri = $ns->namespace_uri($prefix)->uri->value;
77 2         6 $nsmap{$nsuri} = $prefix;
78             }
79             }
80             else {
81 3         6 my %ns = %{ $ns };
  3         13  
82 3         15 while (my ($ns, $uri) = each(%ns)) {
83 7         18 for (1..2) {
84 14 50       35 $uri = $uri->uri_value if (blessed($uri));
85             }
86 7         29 $nsmap{ $uri } = $ns;
87             }
88             }
89 4         13 @{ $self->{namespaces} }{ keys %nsmap } = values %nsmap;
  4         19  
90             }
91 22 50       59 if ($args{base}) {
92 0         0 $self->{base_uri} = $args{base};
93             }
94 22 100       57 if ($args{base_uri}) {
95 1         3 $self->{base_uri} = $args{base_uri};
96             }
97 22 100       57 if ($args{scoped_namespaces}) {
98 1         3 $self->{scoped_namespaces} = $args{scoped_namespaces};
99             }
100 22         74 return $self;
101             }
102              
103             =item C<< serialize_model_to_file ( $fh, $model ) >>
104              
105             Serializes the C<$model> to RDF/XML, printing the results to the supplied
106             filehandle C<<$fh>>.
107              
108             =cut
109              
110             sub serialize_model_to_file {
111 13     13 1 29 my $self = shift;
112 13         24 my $fh = shift;
113 13         24 my $model = shift;
114              
115 13         30 my $st = RDF::Trine::Statement->new( map { variable($_) } qw(s p o) );
  39         99  
116 13         70 my $pat = RDF::Trine::Pattern->new( $st );
117 13         62 my $stream = $model->get_pattern( $pat, undef, orderby => [ qw(s ASC p ASC o ASC) ] );
118 13         59 my $iter = $stream->as_statements( qw(s p o) );
119             # my $iter = $model->as_stream;
120            
121 13         47 $self->serialize_iterator_to_file( $fh, $iter );
122 11         137 return 1;
123             }
124              
125             =item C<< serialize_model_to_string ( $model ) >>
126              
127             Serializes the C<$model> to RDF/XML, returning the result as a string.
128              
129             =cut
130              
131             =item C<< serialize_iterator_to_file ( $file, $iter ) >>
132              
133             Serializes the iterator to RDF/XML, printing the results to the supplied
134             filehandle C<<$fh>>.
135              
136             =cut
137              
138             sub serialize_iterator_to_file {
139 20     20 1 33 my $self = shift;
140 20         31 my $fh = shift;
141 20         31 my $iter = shift;
142            
143 20         52 my $ns = $self->_top_xmlns();
144 20         39 my $base_uri = '';
145 20 100       46 if ($self->{base_uri}) {
146 1         4 $base_uri = "xml:base=\"$self->{base_uri}\" ";
147             }
148 20         32 print {$fh} qq[<?xml version="1.0" encoding="utf-8"?>\n<rdf:RDF ${base_uri}xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"$ns>\n];
  20         119  
149            
150 20         67 my $st = $iter->next;
151 20         31 my @statements;
152 20 100       81 push(@statements, $st) if blessed($st);
153 20         50 while (@statements) {
154 24         45 my $st = shift(@statements);
155 24         39 my @samesubj;
156 24         40 push(@samesubj, $st);
157 24         68 my $subj = $st->subject;
158 24         62 while (my $row = $iter->next) {
159 28 100       70 if ($row->subject->equal( $subj )) {
160 22         66 push(@samesubj, $row);
161             } else {
162 6         13 push(@statements, $row);
163 6         12 last;
164             }
165             }
166            
167 24         47 print {$fh} $self->_statements_same_subject_as_string( @samesubj );
  24         80  
168             }
169            
170 18         33 print {$fh} qq[</rdf:RDF>\n];
  18         64  
171             }
172              
173             sub _statements_same_subject_as_string {
174 24     24   40 my $self = shift;
175 24         53 my @statements = @_;
176 24         68 my $s = $statements[0]->subject;
177            
178 24         44 my $id;
179 24 100       111 if ($s->isa('RDF::Trine::Node::Blank')) {
180 10         30 my $b = $s->blank_identifier;
181 10         26 $id = qq[rdf:nodeID="$b"];
182             } else {
183 14         49 my $i = $s->uri_value;
184 14         33 for ($i) {
185 14         47 s/&/&amp;/g;
186 14         33 s/</&lt;/g;
187 14         30 s/"/&quot;/g;
188             }
189 14         43 $id = qq[rdf:about="$i"];
190             }
191            
192 24         43 my $counter = 1;
193 24         36 my %namespaces = %{ $self->{namespaces} };
  24         83  
194 24         48 my $string = '';
195 24         51 foreach my $st (@statements) {
196 46         127 my (undef, $p, $o) = $st->nodes;
197 46         83 my %used_namespaces;
198 46         73 my ($ns, $ln);
199             try {
200 46     46   1398 ($ns,$ln) = $p->qname;
201             } catch RDF::Trine::Error with {
202 2     2   273 my $uri = $p->uri_value;
203 2         19 throw RDF::Trine::Error::SerializationError -text => "Can't turn predicate $uri into a QName.";
204 46         295 };
205 44         686 $used_namespaces{ $ns }++;
206 44 100       130 unless (exists $namespaces{ $ns }) {
207 17         53 $namespaces{ $ns } = 'ns' . $counter++;
208             }
209 44         80 my $prefix = $namespaces{ $ns };
210 44         69 my $nsdecl = '';
211 44 100       106 if ($self->{scoped_namespaces}) {
212 3         9 $nsdecl = qq[ xmlns:$prefix="$ns"];
213             }
214 44 100       234 if ($o->isa('RDF::Trine::Node::Literal')) {
    100          
215 24         70 my $lv = $o->literal_value;
216 24         51 for ($lv) {
217 24         52 s/&/&amp;/g;
218 24         40 s/</&lt;/g;
219 24         51 s/"/&quot;/g;
220             }
221 24         62 my $lang = $o->literal_value_language;
222 24         59 my $dt = $o->literal_datatype;
223 24         56 my $tag = join(':', $prefix, $ln);
224            
225 24 100       62 if ($lang) {
    100          
226 9         60 $string .= qq[\t<${tag}${nsdecl} xml:lang="${lang}">${lv}</${tag}>\n];
227             } elsif ($dt) {
228 1         9 $string .= qq[\t<${tag}${nsdecl} rdf:datatype="${dt}">${lv}</${tag}>\n];
229             } else {
230 14         67 $string .= qq[\t<${tag}${nsdecl}>${lv}</${tag}>\n];
231             }
232             } elsif ($o->isa('RDF::Trine::Node::Blank')) {
233 6         20 my $b = $o->blank_identifier;
234 6         17 for ($b) {
235 6         17 s/&/&amp;/g;
236 6         14 s/</&lt;/g;
237 6         13 s/"/&quot;/g;
238             }
239 6         34 $string .= qq[\t<${prefix}:$ln${nsdecl} rdf:nodeID="$b"/>\n];
240             } else {
241 14         40 my $u = $o->uri_value;
242 14         32 for ($u) {
243 14         36 s/&/&amp;/g;
244 14         28 s/</&lt;/g;
245 14         33 s/"/&quot;/g;
246             }
247 14         75 $string .= qq[\t<${prefix}:$ln${nsdecl} rdf:resource="$u"/>\n];
248             }
249             }
250            
251 22         60 $string .= qq[</rdf:Description>\n];
252            
253             # rdf namespace is already defined in the <rdf:RDF> tag, so ignore it here
254 22         40 my %seen = %{ $self->{namespaces} };
  22         72  
255 22         50 my @ns;
256 22         52 foreach my $uri (sort { $namespaces{$a} cmp $namespaces{$b} } grep { not($seen{$_}) } (keys %namespaces)) {
  1         5  
  52         129  
257 18         31 my $ns = $namespaces{$uri};
258 18 100       67 my $str = ($ns eq '') ? qq[xmlns="$uri"] : qq[xmlns:${ns}="$uri"];
259 18         40 push(@ns, $str);
260             }
261 22         56 my $ns = join(' ', @ns);
262 22 100       46 if ($ns) {
263 17         181 return qq[<rdf:Description ${ns} $id>\n] . $string;
264             } else {
265 5         45 return qq[<rdf:Description $id>\n] . $string;
266             }
267             }
268              
269             =item C<< serialize_iterator_to_string ( $iter ) >>
270              
271             Serializes the iterator to RDF/XML, returning the result as a string.
272              
273             =cut
274              
275             sub _serialize_bounded_description {
276 0     0   0 my $self = shift;
277 0         0 my $model = shift;
278 0         0 my $node = shift;
279 0         0 my $seen = {};
280            
281 0         0 my $ns = $self->_top_xmlns();
282 0         0 my $base_uri = '';
283 0 0       0 if ($self->{base_uri}) {
284 0         0 $base_uri = "xml:base=\"$self->{base_uri}\" ";
285             }
286 0         0 my $string = qq[<?xml version="1.0" encoding="utf-8"?>\n<rdf:RDF $base_uri$ns>\n];
287 0         0 $string .= $self->__serialize_bounded_description( $model, $node, $seen );
288 0         0 $string .= qq[</rdf:RDF>\n];
289 0         0 return $string;
290             }
291              
292             sub __serialize_bounded_description {
293 0     0   0 my $self = shift;
294 0         0 my $model = shift;
295 0         0 my $node = shift;
296 0   0     0 my $seen = shift || {};
297 0 0       0 return '' if ($seen->{ $node->sse }++);
298            
299 0         0 my $string = '';
300 0         0 my $st = RDF::Trine::Statement->new( $node, map { RDF::Trine::Node::Variable->new($_) } qw(p o) );
  0         0  
301 0         0 my $pat = RDF::Trine::Pattern->new( $st );
302 0         0 my $iter = $model->get_pattern( $pat, undef, orderby => [ qw(p ASC o ASC) ] );
303            
304 0         0 my @bindings = $iter->get_all;
305 0 0       0 if (@bindings) {
306 0         0 my @samesubj = map { RDF::Trine::Statement->new( $node, $_->{p}, $_->{o} ) } @bindings;
  0         0  
307 0 0       0 my @blanks = grep { blessed($_) and $_->isa('RDF::Trine::Node::Blank') } map { $_->{o} } @bindings;
  0         0  
  0         0  
308 0         0 $string .= $self->_statements_same_subject_as_string( @samesubj );
309 0         0 foreach my $object (@blanks) {
310 0         0 $string .= $self->__serialize_bounded_description( $model, $object, $seen );
311             }
312             }
313 0         0 return $string;
314             }
315              
316             sub _top_xmlns {
317 20     20   34 my $self = shift;
318 20         48 my $namespaces = $self->{namespaces};
319 20         67 my @keys = sort { $namespaces->{$a} cmp $namespaces->{$b} } keys %$namespaces;
  13         37  
320 20 100       62 return '' if ($self->{scoped_namespaces});
321            
322 19         36 my @ns;
323 19         39 foreach my $v (@keys) {
324 25 100       69 next if ($v eq 'http://www.w3.org/1999/02/22-rdf-syntax-ns#');
325 6         13 my $k = $namespaces->{$v};
326 6 50       23 if (blessed($v)) {
327 0         0 $v = $v->uri_value;
328             }
329 6 100       33 my $str = ($k eq '') ? qq[xmlns="$v"] : qq[xmlns:$k="$v"];
330 6         17 push(@ns, $str);
331             }
332 19         47 my $ns = join(' ', @ns);
333 19 100       56 if (length($ns)) {
334 3         9 $ns = " $ns";
335             }
336 19         49 return $ns;
337             }
338              
339             1;
340              
341             __END__
342              
343             =back
344              
345             =head1 BUGS
346              
347             Please report any bugs or feature requests to through the GitHub web interface
348             at L<https://github.com/kasei/perlrdf/issues>.
349              
350             =head1 SEE ALSO
351              
352             L<http://www.w3.org/TR/rdf-syntax-grammar/>
353              
354             =head1 AUTHOR
355              
356             Gregory Todd Williams C<< <gwilliams@cpan.org> >>
357              
358             =head1 COPYRIGHT
359              
360             Copyright (c) 2006-2012 Gregory Todd Williams. This
361             program is free software; you can redistribute it and/or modify it under
362             the same terms as Perl itself.
363              
364             =cut