File Coverage

blib/lib/RDF/RDFa/Generator/HTML/Head.pm
Criterion Covered Total %
statement 110 133 82.7
branch 30 54 55.5
condition 16 46 34.7
subroutine 22 22 100.0
pod 4 5 80.0
total 182 260 70.0


line stmt bran cond sub pod time code
1             package RDF::RDFa::Generator::HTML::Head;
2              
3 4     4   77 use 5.008;
  4         15  
4 4     4   33 use base qw'RDF::RDFa::Generator';
  4         11  
  4         557  
5 4     4   30 use strict;
  4         12  
  4         181  
6 4     4   620 use Encode qw'encode_utf8';
  4         16423  
  4         273  
7 4     4   566 use URI::NamespaceMap 1.05;
  4         377676  
  4         187  
8 4     4   2111 use RDF::NS::Curated 0.006;
  4         3255  
  4         135  
9 4     4   3059 use XML::LibXML qw':all';
  4         132591  
  4         30  
10 4     4   783 use Carp;
  4         11  
  4         212  
11 4     4   25 use Scalar::Util qw(blessed);
  4         11  
  4         166  
12              
13 4     4   24 use warnings;
  4         8  
  4         165  
14 4     4   31 use Data::Dumper;
  4         9  
  4         6944  
15              
16             our $VERSION = '0.200';
17              
18             sub new
19             {
20 21     21 1 130202 my ($class, %opts) = @_;
21              
22 21 50 33     163 unless (blessed($opts{namespacemap}) && $opts{namespacemap}->isa('URI::NamespaceMap')) {
23 21 100       83 if (defined $opts{namespaces}) {
24 13         391 $opts{namespacemap} = URI::NamespaceMap->new($opts{namespaces});
25             } else {
26 8         67 my $curated = RDF::NS::Curated->new;
27 8         541 $opts{namespacemap} = URI::NamespaceMap->new($curated->all);
28             }
29            
30             # handle deprecated {ns}.
31 21 50       621088 if (defined($opts{ns})) {
32 0         0 carp "ns option is deprecated by the RDFa serializer";
33             }
34 21         65 while (my ($u,$p) = each %{ $opts{ns} }) {
  21         131  
35 0         0 $opts{namespacemap}->add_mapping($p => $u);
36             }
37              
38 21         77 delete $opts{ns};
39             delete $opts{namespaces}
40 21         55 }
41 21         149 $opts{namespacemap}->guess_and_add('rdfa', 'rdf', 'rdfs', 'xsd');
42 21         190888 bless \%opts, $class;
43             }
44              
45             sub injection_site
46             {
47 8     8 0 54 return '//xhtml:head';
48             }
49              
50             sub inject_document
51             {
52 21     21 1 82 my ($proto, $html, $model, %opts) = @_;
53 21         87 my $dom = $proto->_get_dom($html);
54 21         5499 my @nodes = $proto->nodes($model, %opts);
55            
56 21         717 my $xc = XML::LibXML::XPathContext->new($dom);
57 21         201 $xc->registerNs('xhtml', 'http://www.w3.org/1999/xhtml');
58 21         98 my @sites = $xc->findnodes($proto->injection_site);
59            
60 21 50       1238 die "No suitable place to inject this document." unless @sites;
61            
62 21         370 $sites[0]->appendChild($_) foreach @nodes;
63 21         620 return $dom;
64             }
65              
66             sub create_document
67             {
68 13     13 1 927 my ($proto, $model, %opts) = @_;
69 13 50       85 my $self = (ref $proto) ? $proto : $proto->new;
70            
71 13   50     225 my $html = sprintf(<<HTML, ($self->{'version'}||'1.0'), ($self->{'title'} || 'RDFa Document'), ref $self);
      50        
72             <html xmlns="http://www.w3.org/1999/xhtml" version="XHTML+RDFa %1\$s">
73             <head profile="http://www.w3.org/1999/xhtml/vocab">
74             <title>%2\$s</title>
75             <meta name="generator" value="%3\$s" />
76             </head>
77             <body />
78             </html>
79             HTML
80              
81 13         80 return $proto->inject_document($html, $model, %opts);
82             }
83              
84             sub _get_dom
85             {
86 21     21   82 my ($proto, $html) = @_;
87            
88 21 50       223 return $html if UNIVERSAL::isa($html, 'XML::LibXML::Document');
89            
90 21         144 my $p = XML::LibXML->new;
91 21         461 return $p->parse_string($html);
92             }
93              
94             sub nodes
95             {
96 8     8 1 29 my ($proto, $model) = @_;
97 8 50       80 my $self = (ref $proto) ? $proto : $proto->new;
98            
99 8         35 my $stream = $self->_get_stream($model);
100 8         15415 my @nodes;
101            
102 8         57 while (my $st = $stream->next)
103             {
104 12 100       1705 my $node = $st->object->is_literal ?
105             XML::LibXML::Element->new('meta') :
106             XML::LibXML::Element->new('link');
107 12         464 $node->setNamespace('http://www.w3.org/1999/xhtml', undef, 1);
108            
109 12         317 $self->_process_subject($st, $node)
110             ->_process_predicate($st, $node)
111             ->_process_object($st, $node);
112            
113 12 50 33     99 if (defined($self->{'version'}) && $self->{'version'} == 1.1
      33        
114             and $self->{'prefix_attr'})
115             {
116 0 0       0 if (defined($self->{namespacemap}->rdfa)) {
117             $node->setAttribute('prefix', $self->{namespacemap}->rdfa->as_string)
118 0         0 }
119             } else {
120 12         50 while (my ($prefix, $nsURI) = $self->{namespacemap}->each_map) {
121 476         53956 $node->setNamespace($nsURI->as_string, $prefix, 0);
122             }
123             }
124            
125 12         1295 push @nodes, $node;
126             }
127            
128 8 50       633 return @nodes if wantarray;
129            
130 0         0 my $nodelist = XML::LibXML::NodeList->new;
131 0         0 $nodelist->push(@nodes);
132 0         0 return $nodelist;
133             }
134              
135             sub _get_stream
136             {
137 21     21   85 my ($self, $model) = @_;
138            
139 21         49 my $data_context = undef;
140 21 50       77 if (defined($self->{'data_context'})) {
141 0 0 0     0 if (! blessed($self->{'data_context'})) {
    0          
142 0         0 croak "data_context can't be a string anymore, must be a Attean blank or IRI or an RDF::Trine::Node";
143             } elsif ($self->{'data_context'}->does('Attean::API::BlankOrIRI')
144             || $self->{'data_context'}->isa('RDF::Trine::Node')) {
145 0         0 croak "data_context must be a Attean blank or IRI or an RDF::Trine::Node, not " . ref($self->{'data_context'});
146             }
147             }
148            
149 21         130 return $model->get_quads(undef, undef, undef, $data_context);
150             }
151              
152             sub _process_subject
153             {
154 12     12   38 my ($self, $st, $node) = @_;
155            
156 12 0 33     52 if (defined $self->{'base'}
      33        
157             and $st->subject->is_resource
158             and $st->subject->abs eq $self->{'base'})
159             {
160 0         0 return $self;
161             }
162            
163 12 100       131 if ($st->subject->is_resource)
164 9         424 { $node->setAttribute('about', $st->subject->abs); }
165             else
166 3         100 { $node->setAttribute('about', '[_:'.$st->subject->value.']'); }
167            
168 12         896 return $self;
169             }
170              
171             sub _process_predicate
172             {
173 21     21   66 my ($self, $st, $node) = @_;
174              
175 21 100       107 my $attr = $st->object->is_literal ? 'property' : 'rel';
176              
177 21 50 66     978 if ($attr eq 'rel'
    50 66        
    50 33        
178             and $st->predicate->abs =~ m'^http://www\.w3\.org/1999/xhtml/vocab\#
179             (alternate|appendix|bookmark|cite|
180             chapter|contents|copyright|first|glossary|help|icon|
181             index|last|license|meta|next|p3pv1|prev|role|section|
182             stylesheet|subsection|start|top|up)$'x)
183             {
184 0         0 $node->setAttribute($attr, $1);
185 0         0 return $self;
186             }
187             elsif ($attr eq 'rel'
188             and $st->predicate->abs =~ m'^http://www\.w3\.org/1999/xhtml/vocab#(.*)$')
189             {
190 0         0 $node->setAttribute($attr, ':'.$1);
191 0         0 return $self;
192             }
193             elsif (defined($self->{'version'}) && $self->{'version'} == 1.1)
194             {
195 0         0 $node->setAttribute($attr, $st->predicate->abs);
196 0         0 return $self;
197             }
198            
199 21         2241 $node->setAttribute($attr, $self->_make_curie($st->predicate));
200            
201 21         391 return $self;
202             }
203              
204             sub _process_object
205             {
206 21     21   68 my ($self, $st, $node) = @_;
207            
208 21 50 33     243 if (defined $self->{'base'}
    50 33        
    100 0        
    100 33        
      33        
209             and $st->subject->is_resource
210             and $st->subject->abs eq $self->{'base'}
211             and $st->object->is_resource)
212             {
213 0         0 $node->setAttribute('href', $st->object->abs);
214 0         0 return $self;
215             }
216             elsif (defined $self->{'base'}
217             and $st->object->is_resource
218             and $st->object->abs eq $self->{'base'})
219             {
220 0         0 $node->setAttribute('resource', '');
221 0         0 return $self;
222             }
223             elsif ($st->object->is_resource)
224             {
225 12         577 $node->setAttribute('resource', $st->object->abs);
226 12         927 return $self;
227             }
228             elsif ($st->object->is_blank)
229             {
230 2         132 $node->setAttribute('resource', '[_:'.$st->object->value.']');
231 2         27 return $self;
232             }
233            
234 7         501 $node->setAttribute('content', encode_utf8($st->object->value));
235            
236 7 50       241 if (defined $st->object->datatype)
237             {
238 7         1339 $node->setAttribute('datatype', $self->_make_curie($st->object->datatype));
239             }
240             else
241             {
242 0         0 $node->setAttribute('xml:lang', ''.$st->object->language);
243             }
244            
245 7         114 return $self;
246             }
247              
248             sub _make_curie {
249 74     74   2344 my ($self, $uri) = @_;
250 74         307 my $curie = $self->{namespacemap}->abbreviate($uri);
251 74 100       423160 unless (defined($curie)) {
252 7         94 $uri->value =~ m!(.*)(\#|/)(.*?)$!;
253 7         35 my $trim = $1.$2;
254 7         38 $self->{namespacemap}->guess_and_add($trim);
255 7         303416 $curie = $self->{namespacemap}->abbreviate($uri);
256             }
257 74 50       47432 unless (defined($curie)) {
258 0         0 $curie = $uri->value;
259             }
260 74         446 return $curie;
261             }
262              
263             1;