File Coverage

blib/lib/RDF/RDFa/Generator/HTML/Head.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package RDF::RDFa::Generator::HTML::Head;
2              
3 1     1   22 use 5.008;
  1         4  
  1         41  
4 1     1   4 use base qw'RDF::RDFa::Generator';
  1         2  
  1         115  
5 1     1   6 use strict;
  1         1  
  1         25  
6 1     1   33593 use Encode qw'encode_utf8';
  1         17700  
  1         130  
7 1     1   1743 use RDF::Prefixes;
  1         4742  
  1         50  
8 1     1   7053 use XML::LibXML qw':all';
  0            
  0            
9              
10             our $VERSION = '0.103';
11              
12             sub new
13             {
14             my ($class, %opts) = @_;
15            
16             if (!defined $opts{namespaces})
17             {
18             $opts{namespaces} = {};
19             while (<DATA>)
20             {
21             chomp;
22             my ($p, $u) = split /\s+/;
23             $opts{namespaces}->{$p} ||= $u;
24             }
25             }
26            
27             # handle deprecated {ns}.
28             while (my ($u,$p) = each %{ $opts{ns} })
29             {
30             $opts{namespaces}->{$p} ||= $u;
31             }
32            
33             delete $opts{ns};
34            
35             bless \%opts, $class;
36             }
37              
38             sub injection_site
39             {
40             return '//xhtml:head';
41             }
42              
43             sub inject_document
44             {
45             my ($proto, $html, $model, %opts) = @_;
46             my $dom = $proto->_get_dom($html);
47             my @nodes = $proto->nodes($model, %opts);
48            
49             my $xc = XML::LibXML::XPathContext->new($dom);
50             $xc->registerNs('xhtml', 'http://www.w3.org/1999/xhtml');
51             my @sites = $xc->findnodes($proto->injection_site);
52            
53             die "No suitable place to inject this document." unless @sites;
54            
55             $sites[0]->appendChild($_) foreach @nodes;
56             return $dom;
57             }
58              
59             sub create_document
60             {
61             my ($proto, $model, %opts) = @_;
62             my $self = (ref $proto) ? $proto : $proto->new;
63            
64             my $html = sprintf(<<HTML, ($self->{'version'}||'1.0'), ($self->{'title'} || 'RDFa Document'), ref $self);
65             <html xmlns="http://www.w3.org/1999/xhtml" version="XHTML+RDFa %1\$s">
66             <head profile="http://www.w3.org/1999/xhtml/vocab">
67             <title>%2\$s</title>
68             <meta name="generator" value="%3\$s" />
69             </head>
70             <body />
71             </html>
72             HTML
73              
74             return $proto->inject_document($html, $model, %opts);
75             }
76              
77             sub _get_dom
78             {
79             my ($proto, $html) = @_;
80            
81             return $html if UNIVERSAL::isa($html, 'XML::LibXML::Document');
82            
83             my $p = XML::LibXML->new;
84             return $p->parse_string($html);
85             }
86              
87             sub nodes
88             {
89             my ($proto, $model) = @_;
90             my $self = (ref $proto) ? $proto : $proto->new;
91            
92             my $stream = $self->_get_stream($model);
93             my @nodes;
94            
95             while (my $st = $stream->next)
96             {
97             my $node = $st->object->is_literal ?
98             XML::LibXML::Element->new('meta') :
99             XML::LibXML::Element->new('link');
100             $node->setNamespace('http://www.w3.org/1999/xhtml', undef, 1);
101            
102             my $prefixes = RDF::Prefixes->new($self->{namespaces});
103             $self->_process_subject($st, $node, $prefixes)
104             ->_process_predicate($st, $node, $prefixes)
105             ->_process_object($st, $node, $prefixes);
106            
107             use Data::Dumper; Dumper($prefixes);
108            
109             if ($self->{'version'} == 1.1
110             and $self->{'prefix_attr'})
111             {
112             $node->setAttribute('prefix', $prefixes->rdfa)
113             if %$prefixes;
114             }
115             else
116             {
117             while (my ($u,$p) = each(%$prefixes))
118             {
119             $node->setNamespace($p, $u, 0);
120             }
121             }
122            
123             push @nodes, $node;
124             }
125            
126             return @nodes if wantarray;
127            
128             my $nodelist = XML::LibXML::NodeList->new;
129             $nodelist->push(@nodes);
130             return $nodelist;
131             }
132              
133             sub _get_stream
134             {
135             my ($self, $model) = @_;
136            
137             my $data_context = undef;
138             if (defined $self->{'data_context'})
139             {
140             $data_context = ( $self->{'data_context'} =~ /^_:(.*)$/ ) ?
141             RDF::Trine::Node::Blank->new($1) :
142             RDF::Trine::Node::Resource->new($self->{'data_context'});
143             }
144            
145             return $model->get_statements(undef, undef, undef, $data_context);
146             }
147              
148             sub _process_subject
149             {
150             my ($self, $st, $node, $prefixes) = @_;
151            
152             if (defined $self->{'base'}
153             and $st->subject->is_resource
154             and $st->subject->uri eq $self->{'base'})
155             {
156             return $self;
157             }
158            
159             if ($st->subject->is_resource)
160             { $node->setAttribute('about', $st->subject->uri); }
161             else
162             { $node->setAttribute('about', '[_:'.$st->subject->blank_identifier.']'); }
163            
164             return $self;
165             }
166              
167             sub _process_predicate
168             {
169             my ($self, $st, $node, $prefixes) = @_;
170              
171             my $attr = $st->object->is_literal ? 'property' : 'rel';
172              
173             if ($attr eq 'rel'
174             and $st->predicate->uri =~ m'^http://www\.w3\.org/1999/xhtml/vocab\#
175             (alternate|appendix|bookmark|cite|
176             chapter|contents|copyright|first|glossary|help|icon|
177             index|last|license|meta|next|p3pv1|prev|role|section|
178             stylesheet|subsection|start|top|up)$'x)
179             {
180             $node->setAttribute($attr, $1);
181             return $self;
182             }
183             elsif ($attr eq 'rel'
184             and $st->predicate->uri =~ m'^http://www\.w3\.org/1999/xhtml/vocab#(.*)$')
185             {
186             $node->setAttribute($attr, ':'.$1);
187             return $self;
188             }
189             elsif ($self->{'version'} == 1.1)
190             {
191             $node->setAttribute($attr, $st->predicate->uri);
192             return $self;
193             }
194            
195             $node->setAttribute($attr,
196             $self->_make_curie($st->predicate->uri, $prefixes));
197            
198             return $self;
199             }
200              
201             sub _process_object
202             {
203             my ($self, $st, $node, $prefixes) = @_;
204            
205             if (defined $self->{'base'}
206             and $st->subject->is_resource
207             and $st->subject->uri eq $self->{'base'}
208             and $st->object->is_resource)
209             {
210             $node->setAttribute('href', $st->object->uri);
211             return $self;
212             }
213             elsif (defined $self->{'base'}
214             and $st->object->is_resource
215             and $st->object->uri eq $self->{'base'})
216             {
217             $node->setAttribute('resource', '');
218             return $self;
219             }
220             elsif ($st->object->is_resource)
221             {
222             $node->setAttribute('resource', $st->object->uri);
223             return $self;
224             }
225             elsif ($st->object->is_blank)
226             {
227             $node->setAttribute('resource', '[_:'.$st->object->blank_identifier.']');
228             return $self;
229             }
230            
231             $node->setAttribute('content', encode_utf8($st->object->literal_value));
232            
233             if (defined $st->object->literal_datatype)
234             {
235             $node->setAttribute('datatype',
236             $self->_make_curie($st->object->literal_datatype, $prefixes));
237             }
238             else
239             {
240             $node->setAttribute('xml:lang', ''.$st->object->literal_value_language);
241             }
242            
243             return $self;
244             }
245              
246             sub _make_curie
247             {
248             my ($self, $uri, $prefixes) = @_;
249             use Data::Dumper; Dumper($prefixes); # this shouldn't do anything, but it fixes a bug!!
250             return $prefixes->get_qname($uri);
251             }
252              
253             1;
254              
255             __DATA__
256             bibo http://purl.org/ontology/bibo/
257             cc http://creativecommons.org/ns#
258             ctag http://commontag.org/ns#
259             dbp http://dbpedia.org/property/
260             dc http://purl.org/dc/terms/
261             doap http://usefulinc.com/ns/doap#
262             fb http://developers.facebook.com/schema/
263             foaf http://xmlns.com/foaf/0.1/
264             geo http://www.w3.org/2003/01/geo/wgs84_pos#
265             gr http://purl.org/goodrelations/v1#
266             ical http://www.w3.org/2002/12/cal/ical#
267             og http://opengraphprotocol.org/schema/
268             owl http://www.w3.org/2002/07/owl#
269             rdf http://www.w3.org/1999/02/22-rdf-syntax-ns#
270             rdfa http://www.w3.org/ns/rdfa#
271             rdfs http://www.w3.org/2000/01/rdf-schema#
272             rel http://purl.org/vocab/relationship/
273             rev http://purl.org/stuff/rev#
274             rss http://purl.org/rss/1.0/
275             sioc http://rdfs.org/sioc/ns#
276             skos http://www.w3.org/2004/02/skos/core#
277             tag http://www.holygoat.co.uk/owl/redwood/0.1/tags/
278             v http://rdf.data-vocabulary.org/#
279             vann http://purl.org/vocab/vann/
280             vcard http://www.w3.org/2006/vcard/ns#
281             void http://rdfs.org/ns/void#
282             xfn http://vocab.sindice.com/xfn#
283             xhv http://www.w3.org/1999/xhtml/vocab#
284             xsd http://www.w3.org/2001/XMLSchema#