File Coverage

blib/lib/RDF/Simple/Parser/Handler.pm
Criterion Covered Total %
statement 253 294 86.0
branch 58 82 70.7
condition 28 49 57.1
subroutine 28 29 96.5
pod 1 19 5.2
total 368 473 77.8


line stmt bran cond sub pod time code
1              
2             package RDF::Simple::Parser::Handler;
3              
4 8     8   62 use strict;
  8         19  
  8         251  
5 8     8   49 use warnings;
  8         20  
  8         212  
6              
7 8     8   42 use Carp;
  8         19  
  8         443  
8 8     8   2531 use Data::Dumper; # for debugging only
  8         26162  
  8         455  
9 8     8   3228 use RDF::Simple::NS;
  8         21  
  8         296  
10 8     8   3241 use RDF::Simple::Parser::Attribs;
  8         26  
  8         293  
11 8     8   3459 use RDF::Simple::Parser::Element;
  8         32  
  8         324  
12              
13 8     8   59 use constant DEBUG => 0;
  8         16  
  8         642  
14              
15             use Class::MethodMaker [
16 8         44 scalar => [ qw/ stack base genID disallowed qnames result bnode_absolute_prefix / ],
17 8     8   56 ];
  8         16  
18              
19             my
20             $VERSION = 1.17;
21              
22             sub new
23             {
24 12     12 0 218 DEBUG && print STDERR " FFF Handler::new(@_)\n";
25 12         63 my ($class, $sink, %p) = @_;
26 12   33     82 my $self = bless {}, ref $class || $class;
27 12         328 $self->base($p{'base'});
28 12         397 $self->qnames($p{qnames});
29 12         360 $self->genID(1);
30 12         397 $self->stack([]);
31 12         96 my @dis;
32 12         44 foreach my $s (qw( RDF ID about bagID parseType resource nodeID datatype li aboutEach aboutEachPrefix ))
33             {
34 132         278 push @dis, $self->ns->uri('rdf').$s;
35             } # foreach
36 12         365 $self->disallowed(\@dis);
37 12         135 return $self;
38             } # new
39              
40             =head1 METHODS
41              
42             =over
43              
44             =cut
45              
46             sub addns
47             {
48 106     106 0 233 my ($self, $prefix, $uri) = @_;
49 106         142 DEBUG && print STDERR " DDD Handler::addns($prefix => $uri)\n";
50 106         217 $self->ns->lookup($prefix,$uri);
51             } # addns
52              
53             sub ns
54             {
55 504     504 0 905 my $self = shift;
56 504 100       1771 return $self->{_ns} if $self->{_ns};
57 12         74 $self->{_ns} = RDF::Simple::NS->new;
58             } # ns
59              
60              
61             sub _triple
62             {
63 79     79   245 my $self = shift;
64 79         169 my ($s, $p, $o) = @_;
65 79         108 if (DEBUG)
66             {
67             print STDERR " FFF $self ->_triple($s,$p,$o)\n";
68             # print STDERR Dumper(\@_);
69             my ($package, $file, $line, $sub) = caller(1);
70             print STDERR " DDD called from $sub line $line\n";
71             } # if
72 79         1902 my $r = $self->result;
73 79         790 push @$r, [$s,$p,$o];
74 79         1731 $self->result($r);
75             } # _triple
76              
77             sub start_element
78             {
79 104     104 0 69433 my ($self, $sax) = @_;
80 104         155 DEBUG && print STDERR " FFF start_element($sax->{LocalName})\n";
81 104         155 DEBUG && print STDERR Dumper($sax->{Attributes});
82 104 100       294 if ($sax->{LocalName} eq 'RDF')
83             {
84             # This is the toplevel element of the RDF document. See if there
85             # is an xml:base URL specified:
86 12         25 foreach my $rh (values %{$sax->{Attributes}})
  12         61  
87             {
88 38 100 66     163 if (($rh->{Prefix} eq 'xml') && ($rh->{LocalName} eq 'base'))
89             {
90             # Found the xml:base!
91 2         9 $self->addns(q{_perl_module_rdf_simple_base_} => $rh->{Value});
92             } # if
93             } # foreach
94             } # if
95 104         164 my $e;
96 104         2943 my $stack = $self->stack;
97 104         897 my $parent;
98 104 100       257 if (scalar(@$stack) > 0)
99             {
100 92         170 $parent = $stack->[-1];
101             }
102             my $attrs = RDF::Simple::Parser::Attribs->new($sax->{Attributes},
103 104         2472 $self->qnames);
104             # Add namespace to our lookup table:
105 104         376 $self->addns($sax->{Prefix} => $sax->{NamespaceURI});
106             $e = RDF::Simple::Parser::Element->new(
107             $sax->{NamespaceURI},
108             $sax->{Prefix},
109             $sax->{LocalName},
110 104         2556 $parent,
111             $attrs,
112             qnames => $self->qnames,
113             base => $self->base,
114             );
115 104         177 push @{$e->xtext}, $e->qname.$e->attrs;
  104         2274  
116 104         2057 push @{$stack}, $e;
  104         267  
117 104         2333 $self->stack($stack);
118             } # start_element
119              
120             sub characters
121             {
122 187     187 0 14202 my ($self, $chars) = @_;
123 187   50     534 my $stack = $self->{stack} || [];
124 187         530 $stack->[-1]->{text} .= $chars->{Data};
125 187         524 $stack->[-1]->{xtext}->[-1] .= $chars->{Data};
126 187         4681 $self->stack($stack);
127             } # characters
128              
129             sub end_element
130             {
131 104     104 0 15488 my ($self, $sax) = @_;
132 104         190 my $name = $sax->{LocalName};
133 104         168 my $qname = $sax->{Name};
134 104         138 DEBUG && print STDERR " FFF end_element($name,$qname)\n";
135 104         2662 my $stack = $self->stack;
136 104         842 my $element = pop @{$stack};
  104         190  
137             # DEBUG && print STDERR " DDD element is ", Dumper($element);
138 104         389 $element->{xtext}->[2] .= '{qname}.'>';
139 104 100       294 if (scalar(@$stack) > 0)
140             {
141 92   100     2185 my $kids = $stack->[-1]->children || [];
142 92         926 push @$kids, $element;
143 92         2158 $stack->[-1]->children($kids);
144 92         723 @{ $element->{xtext} } = grep { defined($_) } @{ $element->{xtext} };
  92         242  
  276         534  
  92         200  
145 92         153 $stack->[-1]->{xtext}->[1] = join('', @{$element->{xtext}});
  92         324  
146 92         2090 $self->stack($stack);
147             }
148             else
149             {
150 12         48 $self->document($element);
151             }
152             } # end_element
153              
154             =item uri
155              
156             Takes a URI (possibly relative to the current RDF document)
157             and returns an absolute URI.
158              
159             =cut
160              
161             sub uri
162             {
163 110     110 1 1532 my ($self, $uri) = @_;
164 110   100     231 my $sBase = $self->ns->uri('_perl_module_rdf_simple_base_') || q{};
165 110 50 66     473 if ($uri =~ m/\A:/)
    100          
166             {
167             # URI has empty base.
168 0         0 $uri = qq{$sBase$uri};
169             } # if
170             elsif (($uri =~ m/\A#/) && defined $sBase)
171             {
172             # URI has empty base.
173 11         30 $uri = qq{$sBase$uri};
174             } # if
175 110         1267 return $uri;
176             } # uri
177              
178             sub bNode
179             {
180 11     11 0 54 my ($self, $id, %p) = @_;
181 11         223 my $n_id = sprintf("_:id%08x%04x", time, int rand 0xFFFF);
182 11 50       286 $n_id = $self->bnode_absolute_prefix.$n_id if $self->bnode_absolute_prefix;
183 11         242 return $n_id;
184             } # bNode
185              
186             sub literal
187             {
188 45     45 0 985 my ($self, $string, $attrs) = @_;
189 45         72 DEBUG && print STDERR " FFF literal()\n";
190 45 0 33     121 if ($attrs->{lang} and $attrs->{dtype})
191             {
192 0         0 die "can't have both lang and dtype";
193             } # if
194 45         108 return $string;
195             #r_quot = re.compile(r'([^\\])"')
196             # return ''.join(('"%s"' %
197             # r_quot.sub('\g<1>\\"',
198             #`unicode(s)`[2:-1]),
199             # lang and ("@" + lang) or '',
200             # dtype and ("^^<%s>" % dtype) or ''))
201             } # literal
202              
203             sub document
204             {
205 12     12 0 40 my ($self, $doc) = @_;
206 12 50       288 warn("couldn't find rdf:RDF element") unless $doc->URI eq $self->ns->uri('rdf').'RDF';
207 12 100       306 my @children = @{$doc->children} if $doc->children;
  11         333  
208 12 100       144 unless (scalar(@children) > 0)
209             {
210 1         64 warn("no rdf triples found in document!");
211 1         18 return;
212             }
213 11         33 foreach my $e (@children)
214             {
215             # DEBUG && print STDERR Dumper($e);
216 27         78 $self->nodeElement($e);
217             } # foreach
218             } # document
219              
220              
221             sub nodeElement
222             {
223 34     34 0 71 my ($self, $e) = @_;
224 34         767 my $dissed = $self->disallowed;
225 34         285 my $dis = grep {$_ eq $e->URI} @$dissed;
  443         12334  
226 34 50       347 warn("disallowed element used as node") if $dis;
227 34         123 my $rdf = $self->ns->uri('rdf');
228 34   50     837 my $base = $e->base || $self->base || q{};
229 34 100       2017 if ($e->attrs->{$rdf.'ID'})
    100          
    100          
    100          
230             {
231 3         111 $e->subject( $self->uri($base .'#'. $e->attrs->{$rdf.'ID'}));
232             }
233             elsif ($e->attrs->{$rdf.'about'})
234             {
235 24         1774 $e->subject( $self->uri( $e->attrs->{$rdf.'about'} ));
236             }
237             elsif ($e->attrs->{$rdf.'nodeID'})
238             {
239 3         261 $e->subject( $self->bNode($e->attrs->{$rdf.'nodeID'}) );
240             }
241             elsif (not $e->subject)
242             {
243 3         271 $e->subject($self->bNode);
244             }
245 34 100       1092 if ($e->URI ne $rdf.'Description')
246             {
247 13         422 $self->_triple($e->subject, $rdf.'type', $self->uri($e->URI));
248             }
249 34 50       1007 if ($e->attrs->{$rdf.'type'})
250             {
251 0         0 $self->_triple($e->subject, $rdf.'type', $self->ns->uri($e->{$rdf.'type'}));
252             }
253 34         346 foreach my $k (keys %{$e->attrs})
  34         751  
254             {
255 31         958 my $dis = $self->disallowed;
256 31         288 push @$dis, $rdf.'type';
257 31         83 my ($in) = grep {/$k/} @$dis;
  432         1378  
258 31 50       126 if (not $in)
259             {
260 0         0 my $objt = $self->literal($e->attrs->{$k}, $e->language);
261 0         0 DEBUG && print STDERR " DDD nodeElement _triple(,,$objt)\n";
262 0         0 $self->_triple($e->subject, $self->uri($k), $objt);
263             } # if
264             } # foreach
265 34         832 my $children = $e->children;
266 34         304 foreach my $child (@$children)
267             {
268 57         165 $self->propertyElt($child);
269             } # foreach
270             } # nodeElement
271              
272              
273             sub propertyElt
274             {
275 57     57 0 97 my $self = shift;
276 57         95 my $e = shift;
277 57         74 DEBUG && print STDERR " FFF propertyElt($e)\n";
278             # DEBUG && print STDERR Dumper($e);
279 57         123 my $rdf = $self->ns->uri('rdf');
280 57 100       1429 if ($e->URI eq $rdf.'li')
281             {
282 11   100     324 $e->parent->{liCounter} ||= 1;
283 11         329 $e->URI($rdf.$e->parent->{liCounter});
284 11         367 $e->parent->{liCounter}++;
285             }
286 57   100     1735 my $children = $e->children || [];
287 57 100       1714 if ($e->attrs->{$rdf.'resource'})
288             {
289             # This is an Object Property Declaration Axiom.
290 6         187 $self->_triple($e->parent->subject, $self->uri($e->URI), $e->attrs->{$rdf.'resource'});
291 6         61 return;
292             }
293 51 100 100     681 if (
294             (scalar(@$children) == 1)
295             &&
296             (! $e->attrs->{$rdf.'parseType'})
297             )
298             {
299 3         34 $self->resourcePropertyElt($e);
300 3         36 return;
301             }
302 48 100 100     1102 if ((scalar(@$children) eq 0) && (defined $e->text) && ($e->text ne q{}))
      66        
303             {
304 44         1861 $self->literalPropertyElt($e);
305 44         509 return;
306             }
307 4         103 my $ptype = $e->attrs->{$rdf.'parseType'};
308 4 100       43 if ($ptype)
309             {
310 3 100       11 if ($ptype eq 'Resource')
311             {
312 1         4 $self->parseTypeResourcePropertyElt($e);
313 1         8 return;
314             }
315 2 100       6 if ($ptype eq 'Collection')
316             {
317 1         6 $self->parseTypeCollectionPropertyElt($e);
318 1         11 return;
319             }
320 1         5 $self->parseTypeLiteralOrOtherPropertyElt($e);
321 1         15 return;
322             } # if has a parseType
323 1 50 33     33 if ((! defined $e->text) || ($e->text eq q{}))
324             {
325             # DEBUG && print STDERR Dumper($e);
326 1         15 $self->emptyPropertyElt($e);
327 1         17 return;
328             } # if
329 0         0 delete $e->{parent};
330 0         0 warn " WWW failed to parse element: ", Dumper($e);
331             } # propertyElt
332              
333             sub resourcePropertyElt
334             {
335 3     3 0 8 my ($self, $e) = @_;
336 3         5 DEBUG && print STDERR " FFF resourcePropertyElt($e)\n";
337             # DEBUG && print STDERR Dumper($e);
338 3         7 my $rdf = $self->ns->uri('rdf');
339 3         74 my $n = $e->children->[0];
340 3         41 $self->nodeElement($n);
341 3 50       68 if ($e->parent)
342             {
343 3         86 $self->_triple($e->parent->subject, $self->uri($e->URI), $n->subject);
344             }
345 3 50       83 if ($e->attrs->{$rdf.'ID'})
346             {
347 0   0     0 my $base = $e->base || $self->base;
348 0         0 my $i = $self->uri($base .'#'. $e->attrs->{$rdf.'ID'});
349 0         0 $self->reify($i, $e->parent->subject, $self->uri($e->URI), $n->subject);
350             } # if
351             } # resourcePropertyElt
352              
353              
354             sub reify
355             {
356 0     0 0 0 my ($self,$r,$s,$p,$o) = @_;
357 0         0 my $rdf = $self->ns->uri('rdf');
358 0         0 a $self->_triple($r, $self->uri($rdf.'subject'), $s);
359 0         0 $self->_triple($r, $self->uri($rdf.'predicate'), $p);
360 0         0 $self->_triple($r, $self->uri($rdf.'object'), $o);
361 0         0 $self->_triple($r, $self->uri($rdf.'type'), $self->uri($rdf.'Statement'));
362             } # reify
363              
364              
365             sub literalPropertyElt
366             {
367 44     44 0 86 my ($self, $e) = @_;
368 44         58 DEBUG && print STDERR " FFF literalPropertyElt($e)\n";
369 44   33     980 my $base = $e->base || $self->base;
370 44         1640 my $rdf = $self->ns->uri('rdf');
371 44         1087 my $o = $self->literal($e->text, $e->language, $e->attrs->{$rdf.'datatype'});
372 44         90 DEBUG && print STDERR " DDD literalPropertyElt _triple(,,$o)\n";
373 44         1027 $self->_triple($e->parent->subject, $self->uri($e->URI), $o);
374 44 50       1256 if ($e->attrs->{$rdf.'ID'})
375             {
376 0         0 my $i = $self->uri($base .'#'. $e->attrs->{$rdf.'ID'});
377 0         0 $self->reify($i, $e->parent->subject, $self->uri($e->URI), $o);
378             } # if
379             } # literalPropertyElt
380              
381             sub parseTypeLiteralOrOtherPropertyElt {
382 1     1 0 3 my ($self,$e) = @_;
383 1         2 DEBUG && print STDERR " FFF parseTypeLiteralOrOtherPropertyElt($e)\n";
384 1   33     24 my $base = $e->base || $self->base;
385 1         38 my $rdf = $self->ns->uri('rdf');
386 1         25 my $o = $self->literal($e->xtext->[1],$e->language,$rdf.'XMLLiteral');
387 1         3 DEBUG && print STDERR " DDD parseTypeLiteralOrOtherPropertyElt _triple(,,$o)\n";
388 1         26 $self->_triple($e->parent->subject,$self->uri($e->URI),$o);
389 1 50       44 if ($e->attrs->{$rdf.'ID'}) {
390 0         0 my $i = $self->uri($base .'#'. $e->attrs->{$rdf.'ID'});
391 0         0 $e->subject($i);
392 0         0 $self->reify($i,$e->parent->subject,$self->URI($e->URI),$o);
393             }
394             }
395              
396             sub parseTypeResourcePropertyElt
397             {
398 1     1 0 4 my ($self,$e) = @_;
399 1         2 DEBUG && print STDERR " FFF parseTypeResourcePropertyElt($e)\n";
400 1         4 my $n = $self->bNode;
401 1         2 DEBUG && print STDERR " DDD parseTypeResourcePropertyElt _triple(,,$n)\n";
402 1         25 $self->_triple($e->parent->subject, $self->uri($e->URI), $n);
403 1         29 my $c = RDF::Simple::Parser::Element->new('http://www.w3.org/1999/02/22-rdf-syntax-ns#',
404             'rdf',
405             'Description',
406             $e->parent,
407             $e->attrs,
408             qnames => $self->qnames,
409             base => $e->base,
410             );
411 1         24 $c->subject($n);
412 1         8 my @c_children;
413 1         23 my $children = $e->children;
414 1         10 foreach (@$children)
415             {
416 2         44 $_->parent($c);
417 2         17 push @c_children, $_;
418             }
419 1         24 $c->children(\@c_children);
420 1         10 $self->nodeElement($c);
421             } # parseTypeResourcePropertyElt
422              
423             sub parseTypeCollectionPropertyElt
424             {
425 1     1 0 3 my ($self,$e) = @_;
426 1         2 DEBUG && print STDERR " FFF parseTypeCollectionPropertyElt($e)\n";
427 1         6 my $rdf = $self->ns->uri('rdf');
428 1         24 my $children = $e->children;
429 1         10 my @s;
430 1         3 foreach (@$children)
431             {
432 3         9 $self->nodeElement($_);
433 3         8 push @s, $self->bNode;
434             }
435 1 50       6 if (scalar(@s) eq 0)
436             {
437 0         0 $self->_triple($e->parent->subject,$self->uri($e->URI),$self->uri($rdf.'nil'));
438             }
439             else
440             {
441 1         24 $self->_triple($e->parent->subject,$self->uri($e->URI),$s[0]);
442 1         9 foreach my $n (@s)
443             {
444 3         25 $self->_triple($n,$self->uri($rdf.'type'),$self->uri($rdf.'List'));
445             }
446 1         12 for (0 .. $#s)
447             {
448 3         26 $self->_triple($s[$_],$self->uri($rdf.'first'),$e->children->[$_]->subject);
449             }
450 1         12 for (0 .. ($#s-1))
451             {
452 2         14 $self->_triple($s[$_],$self->uri($rdf.'rest'),$s[$_+1]);
453             }
454 1         12 $self->_triple($s[-1],$self->uri($rdf.'rest'),$self->uri($rdf.'nil'));
455             }
456             } # parseTypeCollectionPropertyElt
457              
458              
459             sub emptyPropertyElt
460             {
461 1     1 0 3 my $self = shift;
462 1         2 my $e = shift;
463 1         1 DEBUG && print STDERR " FFF emptyPropertyElt($e)\n";
464             # DEBUG && print STDERR Dumper($e);
465 1         3 my $rdf = $self->ns->uri('rdf');
466 1 50       26 my $base = $e->base or $self->base;
467 1   50     41 $base ||= '';
468 1         1 my @keys = keys %{$e->attrs};
  1         23  
469 1         11 my $ids = $rdf.'ID';
470 1         3 my ($id) = grep {/$ids/} @keys;
  0         0  
471 1         2 my $r;
472 1 50       3 if ($id)
473             {
474 0         0 $r = $self->literal($e->text, $e->language); # was o
475 0         0 DEBUG && print STDERR " DDD emptyPropertyElt _triple(,,$r)\n";
476 0         0 $self->_triple($e->parent->subject, $self->uri($e->URI), $r);
477             }
478             else
479             {
480 1 50       23 if ($e->attrs->{$rdf.'resource'})
    50          
481             {
482 0         0 my $res = $e->attrs->{$rdf.'resource'};
483 0   0     0 $res ||= '';
484 0 0       0 $res = $base.$res if $res !~ m/\:\/\//;
485 0         0 $r = $self->uri($res);
486             }
487             elsif ($e->attrs->{$rdf.'nodeID'})
488             {
489 0         0 $r = $self->bNode($e->attrs->{$rdf.'nodeID'});
490             }
491             else
492             {
493 1         53 DEBUG && print STDERR " DDD element has no 'resource' attr and no 'nodeID' attr.\n";
494             # Generate a new node ID, in case this empty element has attributes:
495 1         4 $r = $self->bNode;
496             }
497 1         33 my $dis = $self->disallowed;
498 1         8 my @a = map { grep {!/$_/} @$dis } keys %{$e->attrs};
  0         0  
  0         0  
  1         23  
499 1 50       11 if (scalar(@a) < 1)
500             {
501             # This empty element has no attributes, nothing to declare.
502             # Just add empty string to the triple:
503 1         3 $r = q{};
504             } # if
505 1         3 foreach my $a (@a)
506             {
507 0 0       0 if ($a ne $rdf.'type')
508             {
509 0         0 my $o = $self->literal($e->attrs->{$a}, $e->language);
510 0         0 DEBUG && print STDERR " DDD emptyPropertyElt _triple(,,$o)\n";
511 0         0 $self->_triple($r, $self->uri($a), $o);
512             } # if
513             else
514             {
515 0         0 $self->_triple($r, $self->uri($rdf.'type'), $self->uri($e->attrs->{$a}));
516             }
517             } # foreach
518 1         34 $self->_triple($e->parent->subject, $self->uri($e->URI), $r);
519             } # else ! $id
520 1 50       29 if ($e->attrs->{$rdf.'ID'})
521             {
522 0           my $i = $self->uri($base .'#'. $e->attrs->{$rdf.'ID'});
523 0           $self->reify($i, $e->parent->subject, $self->uri($e->URI,$r));
524             }
525             } # emptyPropertyElt
526              
527              
528             =back
529              
530             =head1 NOTES
531              
532             This parser is a transliteration of
533             Sean B Palmer's python RDF/XML parser:
534              
535             http://www.infomesh.net/2003/rdfparser/
536              
537             Thus the idioms inside are a bit pythonic.
538             Most credit for the effort is due to sbp.
539              
540             =cut
541              
542             1;
543              
544             __END__