File Coverage

blib/lib/XML/Feed.pm
Criterion Covered Total %
statement 56 119 47.0
branch 11 44 25.0
condition 3 8 37.5
subroutine 14 22 63.6
pod 8 9 88.8
total 92 202 45.5


line stmt bran cond sub pod time code
1             package XML::Feed;
2 28     28   513298 use strict;
  28         64  
  28         798  
3 28     28   142 use warnings;
  28         48  
  28         888  
4              
5 28     28   155 use base qw( Class::ErrorHandler );
  28         53  
  28         21800  
6 28     28   27595 use Feed::Find;
  28         1708065  
  28         955  
7 28     28   22169 use URI::Fetch;
  28         2188181  
  28         1026  
8 28     28   242 use LWP::UserAgent;
  28         59  
  28         614  
9 28     28   180 use Carp;
  28         61  
  28         1849  
10 28     28   158 use Scalar::Util 'blessed';
  28         61  
  28         1605  
11 28         204 use Module::Pluggable search_path => "XML::Feed::Format",
12             require => 1,
13 28     28   25159 sub_name => 'formatters';
  28         357666  
14              
15             our $VERSION = '0.53';
16             our $MULTIPLE_ENCLOSURES = 0;
17             our @formatters;
18             BEGIN {
19 28     28   3634 @formatters = __PACKAGE__->formatters;
20             }
21              
22             sub new {
23 7     7 1 1302 my $class = shift;
24 7   100     42 my $format = shift || 'Atom';
25 7         23 my $format_class = 'XML::Feed::Format::' . $format;
26 7     7   597 eval "use $format_class";
  7         149  
  0            
  0            
27 7 50       2441 Carp::croak("Unsupported format $format: $@") if $@;
28 0         0 my $feed = bless {}, join('::', __PACKAGE__, "Format", $format);
29 0 0       0 $feed->init_empty(@_) or return $class->error($feed->errstr);
30 0         0 $feed;
31             }
32              
33 0     0 0 0 sub init_empty { 1 }
34              
35             sub parse {
36 17     17 1 4002 my $class = shift;
37 17         50 my($stream, $specified_format) = @_;
38 17 50       80 return $class->error("Stream parameter is required") unless $stream;
39 17         57 my $feed = bless {}, $class;
40 17         40 my $xml = '';
41 17 50 33     311 if (blessed($stream) and $stream->isa('URI')) {
    50          
    50          
42 0         0 my $ua = LWP::UserAgent->new;
43 0         0 $ua->agent(__PACKAGE__ . "/$VERSION");
44 0         0 $ua->env_proxy; # force allowing of proxies
45 0 0       0 my $res = URI::Fetch->fetch($stream, UserAgent => $ua)
46             or return $class->error(URI::Fetch->errstr);
47 0 0       0 return $class->error("This feed has been permanently removed")
48             if $res->status == URI::Fetch::URI_GONE();
49 0         0 $xml = $res->content;
50             } elsif (ref($stream) eq 'SCALAR') {
51 0         0 $xml = $$stream;
52             } elsif (ref($stream)) {
53 0         0 while (read($stream, my($chunk), 8192)) {
54 0         0 $xml .= $chunk;
55             }
56             } else {
57 17 50       790 open my $fh, $stream
58             or return $class->error("Can't open $stream: $!");
59 17         598 while (read $fh, my($chunk), 8192) {
60 18         131 $xml .= $chunk;
61             }
62 17         170 close $fh;
63             }
64 17 50       64 return $class->error("Can't get feed XML content from $stream")
65             unless $xml;
66 17         35 my $format;
67 17 50       54 if ($specified_format) {
68 0         0 $format = $specified_format;
69             } else {
70 17 50       86 $format = $feed->identify_format(\$xml) or return $class->error($feed->errstr);
71             }
72              
73 0         0 my $format_class = join '::', __PACKAGE__, "Format", $format;
74 0         0 eval "use $format_class";
75 0 0       0 return $class->error("Unsupported format $format: $@") if $@;
76 0         0 bless $feed, $format_class;
77 0 0       0 $feed->init_string(\$xml) or return $class->error($feed->errstr);
78 0         0 $feed;
79             }
80              
81             sub identify_format {
82 17     17 1 38 my $feed = shift;
83 17         32 my($xml) = @_;
84 17         63 foreach my $class (@formatters) {
85 17         154 my ($name) = ($class =~ m!([^:]+)$!);
86             # TODO ugly
87 17         52 my $tmp = $$xml;
88 17 50       33 return $name if eval { $class->identify(\$tmp) };
  17         478  
89 17 50       206 return $feed->error($@) if $@;
90             }
91 0         0 return $feed->error("Cannot detect feed type");
92             }
93              
94             sub _get_first_tag {
95 0     0   0 my $class = shift;
96 0         0 my ($xml) = @_;
97              
98              
99             ## Auto-detect feed type based on first element. This is prone
100             ## to breakage, but then again we don't want to parse the whole
101             ## feed ourselves.
102 0         0 my $tag;
103 0         0 while ($$xml =~ /<(\S+)/sg) {
104 0         0 (my $t = $1) =~ tr/a-zA-Z0-9:\-\?!//cd;
105 0         0 my $first = substr $t, 0, 1;
106 0 0 0     0 $tag = $t, last unless $first eq '?' || $first eq '!';
107             }
108 0 0       0 die ("Cannot find first element") unless $tag;
109 0         0 $tag =~ s/^.*://;
110 0         0 return $tag;
111             }
112              
113             sub find_feeds {
114 0     0 1 0 my $class = shift;
115 0         0 my($uri) = @_;
116 0 0       0 my @feeds = Feed::Find->find($uri)
117             or return $class->error(Feed::Find->errstr);
118 0         0 @feeds;
119             }
120              
121             sub convert {
122 0     0 1 0 my $feed = shift;
123 0         0 my($format) = @_;
124 0         0 my $new = XML::Feed->new($format);
125 0         0 for my $field (qw( title link description language author copyright modified generator )) {
126 0         0 my $val = $feed->$field();
127 0 0       0 next unless defined $val;
128 0         0 $new->$field($val);
129             }
130 0         0 for my $entry ($feed->entries) {
131 0         0 $new->add_entry($entry->convert($format));
132             }
133 0         0 $new;
134             }
135              
136             sub splice {
137 0     0 1 0 my $feed = shift;
138 0         0 my($other) = @_;
139 0         0 my %ids = map { $_->id => 1 } $feed->entries;
  0         0  
140 0         0 for my $entry ($other->entries) {
141 0 0       0 $feed->add_entry($entry) unless $ids{$entry->id}++;
142             }
143             }
144              
145             sub _convert_entry {
146 0     0   0 my $feed = shift;
147 0         0 my $entry = shift;
148 0         0 my $feed_format = ref($feed); $feed_format =~ s!^XML::Feed::Format::!!;
  0         0  
149 0         0 my $entry_format = ref($entry); $entry_format =~ s!^XML::Feed::Entry::Format::!!;
  0         0  
150 0 0       0 return $entry if $entry_format eq $feed_format;
151 0         0 return $entry->convert($feed_format);
152             }
153              
154             sub base;
155             sub format;
156             sub title;
157             sub link;
158             sub self_link;
159             sub description;
160             sub language;
161             sub author;
162             sub copyright;
163             sub modified;
164             sub generator;
165             sub add_entry;
166             sub entries;
167             sub as_xml;
168             sub id;
169             sub image;
170              
171 0     0 1 0 sub tagline { shift->description(@_) }
172 0     0 1 0 sub items { $_[0]->entries }
173              
174             # RFC 5005
175             sub first_link;
176             sub last_link;
177             sub previous_link;
178             sub next_link;
179             sub current_link;
180             sub prev_archive_link;
181             sub next_archive_link;
182              
183             1;
184             __END__