File Coverage

blib/lib/App/RSS2Leafnode/XML/Twig/Other.pm
Criterion Covered Total %
statement 12 36 33.3
branch 0 8 0.0
condition 0 3 0.0
subroutine 4 8 50.0
pod 0 4 0.0
total 16 59 27.1


line stmt bran cond sub pod time code
1             # Copyright 2007, 2008, 2009, 2010, 2011, 2012, 2013 Kevin Ryde
2             #
3             # This file is part of RSS2Leafnode.
4             #
5             # RSS2Leafnode is free software; you can redistribute it and/or modify it
6             # under the terms of the GNU General Public License as published by the Free
7             # Software Foundation; either version 3, or (at your option) any later
8             # version.
9             #
10             # RSS2Leafnode is distributed in the hope that it will be useful, but
11             # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
12             # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13             # for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with RSS2Leafnode. If not, see .
17              
18             package App::RSS2Leafnode::XML::Twig::Other;
19 1     1   14 use 5.004;
  1         2  
  1         30  
20 1     1   4 use strict;
  1         1  
  1         24  
21 1     1   4 use Exporter;
  1         2  
  1         29  
22 1     1   5 use vars '$VERSION', '@ISA', '@EXPORT_OK';
  1         1  
  1         410  
23              
24             $VERSION = 77;
25             @ISA = ('Exporter');
26             @EXPORT_OK = (qw(elt_is_empty
27             elt_tree_strip_prefix
28             ));
29              
30             # XML::Twig
31              
32             sub elt_is_empty {
33 0     0 0   my ($elt) = @_;
34 0   0       return ($elt->has_no_atts
35             && ! $elt->has_child
36             && $elt->text_only =~ /^\s*$/);
37             }
38              
39             sub elt_tree_strip_prefix {
40 0     0 0   my ($elt, $prefix) = @_;
41 0           foreach my $child ($elt->descendants_or_self(qr/^\Q$prefix\E:/)) {
42 0           $child->set_tag ($child->local_name);
43             }
44             }
45              
46             # Return a URI object for string $url.
47             # If $url is relative then it's resolved against xml:base, if available, to
48             # make it absolute.
49             # If $url is undef then return undef, which is handy if passing a possibly
50             # attribute like $elt->att('href').
51             # The feed toplevel has an xml:base set to the feed location if no other
52             # value, so elt_xml_based_uri() ends up relative to the feed location if no
53             # other xml:base.
54             #
55             sub elt_xml_based_uri {
56 0     0 0   my ($elt, $url_str) = @_;
57 0 0         if (! defined $url_str) { return undef; }
  0            
58 0           require URI;
59 0           my $uri = URI->new ($url_str);
60 0 0         if (my $base = elt_xml_base ($elt)) {
61 0           return $uri->abs ($base);
62             } else {
63 0           return $uri;
64             }
65             }
66              
67             # Return a URI object for the xml:base applying to $elt, or undef.
68             sub elt_xml_base {
69 0     0 0   my ($elt) = @_;
70 0           my @relative;
71 0           for ( ; $elt; $elt = $elt->parent) {
72 0 0         next if ! defined (my $base = $elt->att('xml:base'));
73 0           $base = URI->new($base);
74 0 0         if (defined $base->scheme) {
75             # an absolute URL
76 0           while (@relative) {
77 0           $base = (pop @relative)->abs($base);
78             }
79 0           return $base;
80             } else {
81             # a relative path
82 0           push @relative, $base;
83             }
84             }
85             # oops, no base, only relative paths
86 0           return undef;
87             }
88              
89              
90             1;
91             __END__