File Coverage

blib/lib/RDF/Simple/Serialiser.pm
Criterion Covered Total %
statement 126 141 89.3
branch 20 24 83.3
condition 22 37 59.4
subroutine 16 17 94.1
pod 5 5 100.0
total 189 224 84.3


line stmt bran cond sub pod time code
1              
2             package RDF::Simple::Serialiser;
3              
4 4     4   3149 use strict;
  4         8  
  4         139  
5              
6 4     4   41 use constant DEBUG => 0;
  4         7  
  4         323  
7              
8             =head1 NAME
9              
10             RDF::Simple::Serialiser - convert a list of triples to RDF
11              
12             =head1 DESCRIPTION
13              
14             A simple RDF serialiser.
15             Accepts an array of triples, returns a serialised RDF document.
16              
17             =head1 SYNOPSIS
18              
19             my $ser = RDF::Simple::Serialiser->new(
20             # OPTIONAL: Supply your own bNode id prefix:
21             nodeid_prefix => 'a:',
22             );
23             # OPTIONAL: Add your namespaces:
24             $ser->addns(
25             foaf => 'http://xmlns.com/foaf/0.1/',
26             );
27             my $node1 = $ser->genid;
28             my $node2 = $ser->genid;
29             my @triples = (
30             ['http://example.com/url#', 'dc:creator', 'zool@example.com'],
31             ['http://example.com/url#', 'foaf:Topic', '_id:1234'],
32             ['_id:1234','http://www.w3.org/2003/01/geo/wgs84_pos#lat','51.334422']
33             [$node1, 'foaf:name', 'Jo Walsh'],
34             [$node1, 'foaf:knows', $node2],
35             [$node2, 'foaf:name', 'Robin Berjon'],
36             [$node1, 'rdf:type', 'foaf:Person'],
37             [$node2, 'rdf:type','http://xmlns.com/foaf/0.1/Person']
38             [$node2, 'foaf:url', \'http://server.com/NOT/an/rdf/uri.html'],
39             );
40             my $rdf = $ser->serialise(@triples);
41              
42             ## Round-trip example:
43             my $parser = RDF::Simple::Parser->new();
44             my $rdf = LWP::Simple::get('http://www.zooleika.org.uk/foaf.rdf');
45             my @triples = $parser->parse_rdf($rdf);
46             my $new_rdf = $serialiser->serialise(@triples);
47              
48              
49             =head1 METHODS
50              
51             =over
52              
53             =cut
54              
55 4     4   638 use Data::Dumper;
  4         6626  
  4         183  
56 4     4   390 use RDF::Simple::NS;
  4         8  
  4         133  
57 4     4   2137 use Regexp::Common qw(URI);
  4         12466  
  4         19  
58             use Class::MethodMaker [
59 4         27 new => 'new',
60             scalar => [ qw/ baseuri path nodeid_prefix / ],
61 4     4   99239 ];
  4         16730  
62              
63             my
64             $VERSION = 1.13;
65              
66             =item new()
67              
68             =item new(nodeid_prefix => 'prefix')
69              
70             =cut
71              
72             =item serialise( @triples )
73              
74             Accepts a 'bucket of triples'
75             (an array of array references which are [subject, predicate, object] statements)
76             and returns a serialised RDF document.
77              
78             If 'rdf:type' is not provided for a subject,
79             the generic node type 'rdf:Description' is used.
80              
81             =cut
82              
83             sub serialise
84             {
85 5     5 1 35 my ($self,@triples) = @_;
86 5         10 my %object_ids;
87 5         15 foreach (@triples)
88             {
89 19         28 push @{$object_ids{$_->[0]}}, $_;
  19         50  
90             } # foreach
91 5         12 my @objects;
92 5         17 foreach my $k (keys %object_ids)
93             {
94 8         16 push @objects, $self->_make_object(@{$object_ids{$k}});
  8         31  
95             } # foreach
96 5         20 my %ns_lookup = $self->_ns->lookup;
97 5         18 my %ns = ();
98 5         16 my $used = $self->_used;
99 5         20 foreach (keys %$used)
100             {
101 11         27 $ns{$_} = $ns_lookup{$_};
102             } # foreach
103 5         25 my $xml = $self->render(\@objects, \%ns);
104 5         46 return $xml;
105             } # serialise
106              
107              
108             =item serialize
109              
110             A synonym for serialise() for American users.
111              
112             =cut
113              
114             sub serialize
115             {
116 0     0 1 0 my $self = shift;
117 0         0 return $self->serialise(@_);
118             } # serialize
119              
120             # _make_object() is called on each subset of triples that have the
121             # same subject.
122              
123             sub _make_object
124             {
125 8     8   19 my $self = shift;
126             # Make a copy of our array-ref arguments, so we can modify them
127             # locally:
128 8         11 my @triples;
129 8         17 foreach my $ra (@_)
130             {
131 19         47 push @triples, [@$ra];
132             } # foreach
133             # DEBUG && print STDERR " DDD in _make_object(), triples is ", Dumper(\@triples);
134 8         15 my $object;
135 8         19 my $rdf = $self->_ns;
136             # Convert the predicate of each triple into a legal qname:
137 8         30 @triples = map {$_->[1] = $rdf->qname($_->[1]); $_} @triples;
  19         58  
  19         48  
138             # Find the type declaration of this subject (assume there is only one):
139 8         16 my ($class) = grep {$_->[1] eq 'rdf:type'} @triples;
  19         48  
140             # DEBUG && print STDERR " DDD in _make_object(), class is ", Dumper($class);
141 8         19 foreach my $t (@triples)
142             {
143             # Register the namespace of (all) the predicates:
144 19         54 $self->_used($t->[1]);
145 19         52 my $qn = $rdf->qname($t->[0]);
146 19 50       54 if ($qn ne $t->[0])
147             {
148             # Register the namespace of (all) the subject(s):
149 0         0 $self->_used($qn);
150             } # if
151             } # foreach
152             # $self->_used('rdf:Description');
153 8 100       20 if ($class)
154             {
155             # This bag of triples has a Class explicitly declared:
156 4         11 $object->{Class} = $rdf->qname($class->[2]);
157             }
158             else
159             {
160             # This bag of triples needs a generic Description Class:
161 4         11 $object->{Class} = 'rdf:Description';
162             }
163             # Register the namespace of this subject's Class:
164 8         28 $self->_used($object->{Class});
165             # Assign identifier as an arbitrary (but resolving) uri:
166 8         18 my $id = $triples[0]->[0];
167 8 100 66     26 if (
      66        
      100        
168             $self->_looks_like_uri($id)
169             ||
170             $self->_looks_like_legal_id($id)
171             ||
172             (($id =~ m/^[#:]/) && $self->_looks_like_legal_id(substr($id,1)))
173             )
174             {
175 5         17 $object->{Uri} = $id;
176             } # if
177             else
178             {
179             # Delete non-alphanumeric characters:
180 3         24 $id =~ s/\W//g;
181 3         10 $object->{NodeId} = $id;
182             }
183 8   50     363 my $pref = $self->nodeid_prefix || '_id:';
184             STATEMENT:
185 8         110 foreach my $statement (@triples)
186             {
187 19 100       67 next if $statement->[1] eq 'rdf:type';
188 15         25 my $obj = $statement->[2];
189 15         23 DEBUG && print STDERR " DDD start processing object($obj)\n";
190 15 100 33     104 if (ref $obj)
    50 33        
    50 33        
191             {
192             # Special case: insert this value as a string, no matter what it
193             # looks like:
194 1         1 push @{ $object->{literal}->{$statement->[1]} }, ${$obj};
  1         4  
  1         2  
195             }
196             elsif ($obj =~ m/^$pref/)
197             {
198 0         0 $statement->[2] =~ s/\A[^a-zA-Z]/a/;
199 0         0 $statement->[2] =~ s/\W//g;
200 0         0 push @{ $object->{nodeid}->{$statement->[1]} }, $obj;
  0         0  
201             } # if
202             elsif (
203             $self->_looks_like_uri($obj)
204             ||
205             $self->_looks_like_legal_id($obj)
206             ||
207             (
208             ($obj =~ m/^[#:]/)
209             &&
210             $self->_looks_like_legal_id(substr($obj, 1))
211             )
212             )
213             {
214 0         0 push @{ $object->{resource}->{$statement->[1]} }, $obj;
  0         0  
215             }
216             else
217             {
218 14         24 push @{ $object->{literal}->{$statement->[1]} }, $obj;
  14         117  
219             }
220             } # foreach
221 8         34 return $object;
222             } # _make_object
223              
224              
225             sub _looks_like_uri
226             {
227 22     22   37 my $self = shift;
228 22   50     72 my $s = shift || '';
229             return (
230 22   66     106 ($s =~ m/$RE{URI}/)
231             &&
232             # The URI we're interested in are specifically those URI
233             # that can refer to an element of an ontology; these always
234             # look like namespace#name
235             ($s =~ m/.#./)
236             );
237             } # _looks_like_uri
238              
239             sub _looks_like_legal_id
240             {
241 26     26   8949 my $self = shift;
242 26   50     111 my $s = shift || '';
243             return (
244             # Starts with alphanumeric:
245 26   100     281 ($s =~ m/\A\w/)
246             &&
247             # Only consists of alphanumerics plus a few punctuations.
248             # I'm not sure what the correct set of characters is, even
249             # after reading the RDF specification (it only refers to
250             # full URIs):
251             ($s =~ m/\A[-:_a-z0-9]+\z/)
252             );
253             } # _looks_like_legal_id
254              
255              
256             =item addns( qname => 'http://example.com/rdf/vocabulary#',
257             qname2 => 'http://yetanother.org/vocabulary/' )
258              
259              
260             Use this method to add new namespaces to the RDF document.
261             The RDF::Simple::NS module
262             provides the following vocabularies by default
263             (you can override them if you wish):
264              
265             foaf => 'http://xmlns.com/foaf/0.1/',
266             dc => 'http://purl.org/dc/elements/1.1/',
267             rdfs => 'http://www.w3.org/2000/01/rdf-schema#',
268             daml => 'http://www.w3.org/2001/10/daml+oil#',
269             space => 'http://frot.org/space/0.1/',
270             geo => 'http://www.w3.org/2003/01/geo/wgs84_pos#',
271             rdf => 'http://www.w3.org/1999/02/22-rdf-syntax-ns#',
272             owl => 'http://www.w3.org/2002/07/owl#',
273             ical => 'http://www.w3.org/2002/12/cal/ical#',
274             dcterms => 'http://purl.org/dc/terms/',
275             wiki => 'http://purl.org/rss/1.0/modules/wiki/',
276             chefmoz => 'http://chefmoz.org/rdf/elements/1.0/',
277              
278             =cut
279              
280             sub addns
281             {
282 4     4 1 848 my $self = shift;
283 4         18 my %p;
284 4 100       22 if (ref $_[0] eq 'HASH')
285             {
286 3         6 %p = %{$_[0]};
  3         31  
287             }
288             else
289             {
290 1         4 %p = @_;
291             }
292 4         21 return $self->_ns->lookup(%p);
293             } # addns
294              
295              
296             =item genid( )
297              
298             generates a random identifier for use as a bNode
299             (anonymous node) nodeID.
300             if nodeid_prefix is set, the generated id uses the prefix,
301             followed by 8 random numbers.
302              
303             =cut
304              
305             sub genid
306             {
307 4     4 1 18 my $self = shift;
308 4   50     95 my $prefix = $self->nodeid_prefix || '_id:';
309 4         49 my @num = (0..9);
310 4         8 my $string = join '', (map { @num[rand @num] } 0..7);
  32         67  
311 4         14 return $prefix.$string;
312             } # genid
313              
314             sub _ns
315             {
316 44     44   69 my $self = shift;
317 44 100       163 return $self->{_rdfns} if $self->{_rdfns};
318 4         30 $self->{_rdfns} = RDF::Simple::NS->new;
319             } # _ns
320              
321             sub _used
322             {
323 32     32   57 my ($self, $uri) = @_;
324 32 100 66     150 if (defined $uri and ($uri !~ m/^http/)) {
325 27         52 my $pref = $self->_ns->prefix($uri);
326 27 50       80 $self->{_used_entities}->{ $pref } = 1 if $pref;
327             }
328 32         57 return $self->{_used_entities};
329             } # _used
330              
331              
332             =item render
333              
334             Does the heavy lifting of converting the "objects" to a string.
335             Users of this module should call serialize();
336             Subclassers of this module will probably rewrite render().
337              
338             =cut
339              
340             sub render
341             {
342 5     5 1 15 my ($self, $objects, $ns) = @_;
343 5         11 my $xml = "
344             NS:
345 5         17 foreach my $n (keys %$ns)
346             {
347 11         41 $xml .= 'xmlns:'.$n.'="'.$ns->{$n}."\"\n";
348             } # foreach NS
349 5         16 $xml .= ">\n";
350             OBJECT:
351 5         14 foreach my $object (@$objects)
352             {
353 8         20 $xml .= '<'.$object->{Class};
354 8 100       29 if ($object->{Uri})
355             {
356 5         18 $xml .= ' rdf:about="'.$object->{Uri}.'"';
357             } # if
358             else
359             {
360 3         12 $xml .= ' rdf:nodeID="'.$object->{NodeId}.'"';
361             }
362 8         15 $xml .= ">\n";
363             LITERAL:
364 8         13 foreach my $l (keys %{$object->{literal}})
  8         25  
365             {
366             LITERAL_PROP:
367 15         25 foreach my $prop (@{$object->{literal}->{$l}})
  15         36  
368             {
369 15         32 $prop = _xml_escape($prop);
370 15         66 $xml .= qq{<$l>$prop\n};
371             } # foreach LITERAL_PROP
372             } # foreach LITERAL
373             RESOURCE:
374 8         15 foreach my $l (keys %{$object->{resource}})
  8         26  
375             {
376             RESOURCE_PROP:
377 0         0 foreach my $prop (@{$object->{resource}->{$l}})
  0         0  
378             {
379 0         0 $xml .= qq{<$l rdf:resource="$prop"/>\n};
380             } # foreach RESOURCE_PROP
381             } # foreach RESOURCE
382             NODEID:
383 8         14 foreach my $l (keys %{$object->{nodeid}})
  8         21  
384             {
385             NODEID_PROP:
386 0         0 foreach my $prop (@{$object->{nodeid}->{$l}})
  0         0  
387             {
388 0         0 $xml .= qq{<$l rdf:nodeID="$prop"/>\n};
389             } # foreach NODEID_PROP
390             } # foreach NODEID
391 8         26 $xml .= '{Class} .">\n";
392             } # foreach OBJECT
393 5         13 $xml .= "\n";
394 5         13 return $xml;
395             } # render
396              
397              
398             sub _xml_escape
399             {
400 15   50 15   38 my $s = shift || '';
401             # Make safe for XML:
402 15         51 my %escape = (
403             q'<' => q'<',
404             q'>' => q'>',
405             q'&' => q'&', # ', # Emacs bug
406             q'"' => q'"',
407             );
408 15         44 my $escape_re = join(q'|', keys %escape);
409 15         263 $s =~ s/($escape_re)/$escape{$1}/g;
410 15         54 return $s;
411             } # _xml_escape
412              
413             =back
414              
415             =head1 BUGS
416              
417             Please report bugs via the RT web site L
418              
419             =head1 NOTES
420              
421             The original author was British, so this is a Serialiser.
422             For American programmers,
423             RDF::Simple::Serializer will work as an alias to the module,
424             and serialize() does the same as serialise().
425              
426             The distinction between a URI and a literal string
427             in the "object" (third element) of each triple
428             is made as follows:
429             if the object is a reference, it is output as a literal;
430             if the object "looks like" a URI
431             (according to Regexp::Common::URI),
432             it is output as a URI.
433              
434              
435             =head1 THANKS
436              
437             Thanks particularly to Tom Hukins, and also to Paul Mison, for providing patches.
438              
439             =head1 AUTHOR
440              
441             Originally written by Jo Walsh (formerly ).
442             Currently maintained by Martin Thurn .
443              
444             =head1 LICENSE
445              
446             This module is available under the same terms as perl itself.
447              
448             =cut
449              
450             1;
451              
452             __END__