root/websites/AjaxTB/tb/cgi-lib/XML/FeedPP.pm @ 4124

Revision 4124, 51.7 kB (checked in by kawa0117, 6 years ago)

ajaxtb-20060919.zip

Line 
1=head1 NAME
2
3XML::FeedPP -- Parse/write/merge/edit web feeds, RSS/RDF/Atom
4
5=head1 SYNOPSIS
6
7Get a RSS file and parse it.
8
9    my $source = 'http://use.perl.org/index.rss';
10    my $feed = XML::FeedPP->new( $source );
11    print "Title: ", $feed->title(), "\n";
12    print "Date: ", $feed->pubDate(), "\n";
13    foreach my $item ( $feed->get_item() ) {
14        print "URL: ", $item->link(), "\n";
15        print "Title: ", $item->title(), "\n";
16    }
17
18Generate a RDF file and save it.
19
20    my $feed = XML::FeedPP::RDF->new();
21    $feed->title( "use Perl" );
22    $feed->link( "http://use.perl.org/" );
23    $feed->pubDate( "Thu, 23 Feb 2006 14:43:43 +0900" );
24    my $item = $feed->add_item( "http://search.cpan.org/~kawasaki/XML-TreePP-0.02" );
25    $item->title( "Pure Perl implementation for parsing/writing xml file" );
26    $item->pubDate( "2006-02-23T14:43:43+09:00" );
27    $feed->to_file( "index.rdf" );
28
29Merge some RSS/RDF files and convert it into Atom format.
30
31    my $feed = XML::FeedPP::Atom->new();                # create empty atom file
32    $feed->merge( "rss.xml" );                          # load local RSS file
33    $feed->merge( "http://www.kawa.net/index.rdf" );    # load remote RDF file
34    my $now = time();
35    $feed->pubDate( $now );                             # touch date
36    my $atom = $feed->to_string();                      # get Atom source code
37
38=head1 DESCRIPTION
39
40XML::FeedPP module parses a RSS/RDF/Atom file, converts its format,
41marges another files, and generates a XML file.
42This module is a pure Perl implementation and do not requires any other modules
43expcept for XML::FeedPP.
44
45=head1 METHODS FOR FEED
46
47=head2  $feed = XML::FreePP->new( 'index.rss' );
48
49This constructor method creates a instance of the XML::FeedPP.
50The format of $source must be one of the supported feed fromats: RSS, RDF or Atom.
51The first arguments is the file name on the local file system.
52
53=head2  $feed = XML::FreePP->new( 'http://use.perl.org/index.rss' );
54
55The URL on the remote web server is also available as the first argument.
56LWP::UserAgent module is required to download it.
57
58=head2  $feed = XML::FreePP->new( '<?xml?><rss version="2.0"><channel>....' );
59
60The XML source code is also available as the first argument.
61
62=head2  $feed = XML::FreePP::RSS->new( $source );
63
64This constructor method creates a instance for RSS format.
65The first argument is optional.
66This method returns an empty instance when $source is not defined.
67
68=head2  $feed = XML::FreePP::RDF->new( $source );
69
70This constructor method creates a instance for RDF format.
71The first argument is optional.
72This method returns an empty instance when $source is not defined.
73
74=head2  $feed = XML::FreePP::Atom->new( $source );
75
76This constructor method creates a instance for Atom format.
77The first argument is optional.
78This method returns an empty instance when $source is not defined.
79
80=head2  $feed->load( $source );
81
82This method loads a RSS/RDF/Atom file like new() method do.
83
84=head2  $feed->merge( $source );
85
86This method merges a RSS/RDF/Atom file into existing $feed instance.
87
88=head2  $string = $feed->to_string( $encoding );
89
90This method generates XML source as string and returns it.
91The output $encoding is optional and the default value is 'UTF-8'.
92On Perl 5.8 and later, any encodings supported by Encode module are available.
93On Perl 5.005 and 5.6.1, four encodings supported by Jcode module are only
94available: 'UTF-8', 'Shift_JIS', 'EUC-JP' and 'ISO-2022-JP'.
95But normaly, 'UTF-8' is recommended to the compatibilities.
96
97=head2  $feed->to_file( $filename, $encoding );
98
99This method generate a XML file.
100The output $encoding is optional and the default value is 'UTF-8'.
101
102=head2  $item = $feed->get_item( $num );
103
104This method returns item(s) in $feed.
105If $num is defined, it returns the $num-th item's object.
106If $num is not defined on array context, it returns a array of all items.
107If $num is not defined on scalar context, it returns a number of items.
108
109=head2  $item = $feed->add_item( $url );
110
111This method creates a new item/entry and returns its instance.
112First argument $link is the URL of the new item/entry.
113RSS's <item> element is a instance of XML::FeedPP::RSS::Item class.
114RDF's <item> element is a instance of XML::FeedPP::RDF::Item class.
115Atom's <entry> element is a instance of XML::FeedPP::Atom::Entry class.
116
117=head2  $item = $feed->add_item( $srcitem );
118
119This method duplicates a item/entery and adds it to $feed.
120$srcitem is a XML::FeedPP::*::Item class's instance
121which is returned by get_item() method above.
122
123=head2  $feed->remove_item( $num );
124
125This method removes a item/entry from $feed.
126
127=head2  $feed->clear_item();
128
129This method removes all items/entries from $feed.
130
131=head2  $feed->sort_item();
132
133This method sorts the order of items in $feed by pubDate.
134
135=head2  $feed->uniq_item();
136
137This method makes items unique. The second and succeeding items
138which have a same link URL are removed.
139
140=head2  $feed->limit_item( $num );
141
142This method removes items which exceed the limit specified.
143
144=head2  $feed->normalize();
145
146This method calls both of sort_item() method and uniq_item() method.
147
148=head2  $feed->xmlns( 'xmlns:media' => 'http://search.yahoo.com/mrss' );
149
150This code adds a XML namespace at the document root of the feed.
151
152=head2  $url = $feed->xmlns( 'xmlns:media' );
153
154This code returns the URL of the specified XML namespace.
155
156=head2  @list = $feed->xmlns();
157
158This code returns the list of all XML namespace used in $feed.
159
160=head1  METHODS FOR CHANNEL
161
162=head2  $feed->title( $text );
163
164This method sets/gets the feed's <title> value.
165This method returns the current value when the $title is not defined.
166
167=head2  $feed->description( $html );
168
169This method sets/gets the feed's <description> value in HTML.
170This method returns the current value when the $html is not defined.
171
172=head2  $feed->pubDate( $date );
173
174This method sets/gets the feed's <pubDate> value for RSS,
175<dc:date> value for RDF, or <modified> value for Atom.
176This method returns the current value when the $date is not defined.
177See also the DATE/TIME FORMATS section.
178
179=head2  $feed->copyright( $text );
180
181This method sets/gets the feed's <copyright> value for RSS/Atom,
182or <dc:rights> element for RDF.
183This method returns the current value when the $text is not defined.
184
185=head2  $feed->link( $url );
186
187This method sets/gets the URL of the web site
188as the feed's <link> value for RSS/RDF/Atom.
189This method returns the current value when the $url is not defined.
190
191=head2  $feed->language( $lang );
192
193This method sets/gets the feed's <language> value for RSS,
194<dc:language> element for RDF, or <feed xml:lang=""> attribute for Atom.
195This method returns the current value when the $lang is not defined.
196
197=head2  $feed->image( $url, $title, $link, $description, $width, $height )
198
199This method sets/gets the feed's <image> value and its child nodes
200for RSS/RDF. This method is ignored for Atom.
201This method returns the current values as array when any arguments are not defined.
202
203=head1  METHODS FOR ITEM
204
205=head2  $item->title( $text );
206
207This method sets/gets the item's <title> value.
208This method returns the current value when the $text is not defined.
209
210=head2  $item->description( $html );
211
212This method sets/gets the item's <description> value in HTML.
213This method returns the current value when the $text is not defined.
214
215=head2  $item->pubDate( $date );
216
217This method sets/gets the item's <pubDate> value for RSS,
218<dc:date> element for RDF, or <issued> element for Atom.
219This method returns the current value when the $text is not defined.
220See also the DATE/TIME FORMATS section.
221
222=head2  $item->category( $text );
223
224This method sets/gets the item's <category> value for RSS/RDF.
225This method is ignored for Atom.
226This method returns the current value when the $text is not defined.
227
228=head2  $item->author( $text );
229
230This method sets/gets the item's <author> value for RSS,
231<creator> value for RDF, or <author><name> value for Atom.
232This method returns the current value when the $text is not defined.
233
234=head2  $item->guid( $guid, isPermaLink => $bool );
235
236This method sets/gets the item's <guid> value for RSS
237or <id> value for Atom.
238This method is ignored for RDF.
239The second argument is optional.
240This method returns the current value when the $guid is not defined.
241
242=head2  $item->set( $key => $value, ... );
243
244This method sets some node values or attributes.
245See also the next section: GENERAL SET/GET
246
247=head2  $value = $item->get( $key );
248
249This method returns the node value or attribute.
250See also the next section: GENERAL SET/GET
251
252=head2  $link = $item->link();
253
254This method returns the item's <link> value.
255
256=head1  GENERAL SET/GET
257
258XML::FeedPP understands only <rdf:*>, <dc:*> modules
259and RSS/RDF/ATOM's default namespaces.
260There are NO native methods for any other external modules,
261such as <media:*>.
262But set()/get() methods are available to get/set the value of
263any elements or attributes for these modules.
264
265=head2  $item->set( 'module:name' => $value );
266
267This code sets the value of the child node:
268<item><module:name>$value
269
270=head2  $item->set( 'module:name@attr' => $value );
271
272This code sets the value of the child node's attribute:
273<item><module:name attr="$value">
274
275=head2  $item->set( '@attr' => $value );
276
277This code sets the value of the item's attribute:
278<item attr="$value">
279
280=head2  $item->set( 'hoge/pomu@hare' => $value );
281
282This code sets the value of the child node's child node's attribute:
283<item><hoge><pomu attr="$value">
284
285=head1  DATE/TIME FORMATS
286
287XML::FeedPP allows you to describe date/time by three formats following:
288
289=head2  $date = "Thu, 23 Feb 2006 14:43:43 +0900";
290
291The first format is the format preferred for the HTTP protocol.
292This is the native format of RSS 2.0 and one of the formats defined by RFC 1123.
293
294=head2  $date = "2006-02-23T14:43:43+09:00";
295
296The second format is the W3CDTF format.
297This is the native format of RDF and one of the formats defined by ISO 8601.
298
299=head2  $date = 1140705823;
300
301The last format is the number of seconds since the epoch, 1970-01-01T00:00:00Z.
302You know, this is the native format of Perl's time() function.
303
304=head1 MODULE DEPENDENCIES
305
306XML::FeedPP module requires only XML::TreePP module,
307which is a pure Perl implementation as well.
308LWP::UserAgent module is also required to download a file from remote web server.
309Jcode module is required to convert Japanese encodings on Perl 5.006 and 5.6.1.
310Jcode module is NOT required on Perl 5.8.x and later.
311
312=head1 AUTHOR
313
314Yusuke Kawasaki, http://www.kawa.net/
315
316=head1 COPYRIGHT AND LICENSE
317
318Copyright (c) 2006 Yusuke Kawasaki.  All rights reserved.  This program
319is free software; you can redistribute it and/or modify it under the same
320terms as Perl itself.
321
322=cut
323
324# ----------------------------------------------------------------
325package XML::FeedPP;
326use strict;
327use Carp;
328use Time::Local;
329use XML::TreePP;
330
331use vars qw( $VERSION );
332$VERSION = "0.16";
333
334my $RSS_VERSION  = '2.0';
335my $RDF_VERSION  = '1.0';
336my $ATOM_VERSION = '0.3';
337my $XMLNS_RDF    = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#';
338my $XMLNS_RSS    = 'http://purl.org/rss/1.0/';
339my $XMLNS_DC     = 'http://purl.org/dc/elements/1.1/';
340my $XMLNS_ATOM   = 'http://purl.org/atom/ns#';
341my $XMLNS_NOCOPY = [qw( xmlns xmlns:rdf xmlns:dc xmlns:atom )];
342
343my $TREEPP_OPTIONS = {
344    force_array => [qw( item rdf:li entry )],
345    first_out   => [qw( -rel -type )],
346    last_out    => [qw( description item items entry -width -height )],
347    user_agent  => "XML-FeedPP/$VERSION ",
348};
349
350sub new {
351    my $package = shift;
352    my $source  = shift;
353    Carp::croak "No feed source" unless defined $source;
354
355    my $self  = {};
356    bless $self, $package;
357    $self->load($source, @_);
358
359    if ( exists $self->{rss} ) {
360        XML::FeedPP::RSS->feed_bless($self);
361    }
362    elsif ( exists $self->{'rdf:RDF'} ) {
363        XML::FeedPP::RDF->feed_bless($self);
364    }
365    elsif ( exists $self->{feed} ) {
366        XML::FeedPP::Atom->feed_bless($self);
367    }
368    else {
369        my $root = join( " ", sort keys %$self );
370        Carp::croak "Invalid feed format: $root";
371    }
372    $self->init_feed();
373    $self;
374}
375
376sub feed_bless {
377    my $package = shift;
378    my $self    = shift;
379    bless $self, $package;
380    $self;
381}
382
383sub load {
384    my $self   = shift;
385    my $source = shift;
386    Carp::croak "No feed source" unless defined $source;
387
388    my $tree;
389    my $tpp = XML::TreePP->new(%$TREEPP_OPTIONS, @_);
390    if ( $source =~ m#^https?://# ) {
391        $tree = $tpp->parsehttp( GET => $source );
392    }
393    elsif ( $source =~ m#<\?xml.*\?>#i ) {
394        $tree = $tpp->parse($source);
395    }
396    elsif ( -f $source ) {
397        $tree = $tpp->parsefile($source);
398    }
399    Carp::croak "Invalid feed source: $source" unless ref $tree;
400    %$self = %$tree;    # override myself
401    $self;
402}
403
404sub to_string {
405    my $self   = shift;
406    my $encode = shift;
407    my $opt = { output_encoding => $encode, @_ };
408    my $tpp = XML::TreePP->new( %$TREEPP_OPTIONS, %$opt );
409    $tpp->write( $self, $encode );
410}
411
412sub to_file {
413    my $self   = shift;
414    my $file   = shift;
415    my $encode = shift;
416    my $opt = { output_encoding => $encode, @_ };
417    my $tpp = XML::TreePP->new( %$TREEPP_OPTIONS, %$opt );
418    $tpp->writefile( $file, $self, $encode );
419}
420
421sub merge {
422    my $self   = shift;
423    my $source = shift;
424    my $target = ref $source ? $source : XML::FeedPP->new($source);
425    $self->merge_channel($target);
426    $self->merge_item($target);
427    $self->normalize();
428    undef;
429}
430
431sub merge_channel {
432    my $self   = shift;
433    my $target = shift;
434    if ( ref $self eq ref $target ) {
435        $self->merge_native_channel($target);
436    }
437    else {
438        $self->merge_common_channel($target);
439    }
440}
441
442sub merge_item {
443    my $self   = shift;
444    my $target = shift;
445    foreach my $item ( $target->get_item() ) {
446        $self->add_item( $item );
447    }
448}
449
450sub merge_common_channel {
451    my $self   = shift;
452    my $target = shift;
453
454    my $title1 = $self->title();
455    my $title2 = $target->title();
456    $self->title($title2) if ( !defined $title1 && defined $title2 );
457
458    my $desc1 = $self->description();
459    my $desc2 = $target->description();
460    $self->description($desc2) if ( !defined $desc1 && defined $desc2 );
461
462    my $link1 = $self->link();
463    my $link2 = $target->link();
464    $self->link($link2) if ( !defined $link1 && defined $link2 );
465
466    my $lang1 = $self->language();
467    my $lang2 = $target->language();
468    $self->language($lang2) if ( !defined $lang1 && defined $lang2 );
469
470    my $right1 = $self->copyright();
471    my $right2 = $target->copyright();
472    $self->copyright($right2) if ( !defined $right1 && defined $right2 );
473
474    my $pubDate1 = $self->pubDate();
475    my $pubDate2 = $target->pubDate();
476    $self->pubDate($pubDate2) if ( !defined $pubDate1 && defined $pubDate2 );
477
478    my @image1 = $self->image();
479    my @image2 = $target->image();
480    $self->image(@image2) if ( !defined $image1[0] && defined $image2[0] );
481
482    my @xmlns1 = $self->xmlns();
483    my @xmlns2 = $target->xmlns();
484    my $xmlchk = { map { $_ => 1 } @xmlns1, @$XMLNS_NOCOPY };
485    foreach my $ns (@xmlns2) {
486        next if exists $xmlchk->{$ns};
487        $self->xmlns( $ns, $target->xmlns($ns) );
488    }
489
490    $self->merge_module_nodes( $self->docroot, $target->docroot );
491
492    $self;
493}
494
495sub add_clone_item {
496    my $self = shift;
497    my $srcitem = shift;
498    my $link = $srcitem->link() or return;
499    my $dstitem = $self->add_item( $link );
500
501    if ( ref $dstitem eq ref $srcitem ) {
502        XML::FeedPP::Util::merge_hash( $dstitem, $srcitem );
503    }
504    else {
505#       my $link = $srcitem->link();
506#       $dstitem->link($link) if defined $link;
507
508        my $title = $srcitem->title();
509        $dstitem->title($title) if defined $title;
510
511        my $description = $srcitem->description();
512        $dstitem->description($description) if defined $description;
513
514        my $category = $srcitem->category();
515        $dstitem->category($category) if defined $category;
516
517        my $author = $srcitem->author();
518        $dstitem->author($author) if defined $author;
519
520        my $guid = $srcitem->guid();
521        $dstitem->guid($guid) if defined $guid;
522
523        my $pubDate = $srcitem->pubDate();
524        $dstitem->pubDate($pubDate) if defined $pubDate;
525
526        $self->merge_module_nodes( $dstitem, $srcitem );
527    }
528
529    $dstitem;
530}
531
532sub merge_module_nodes {
533    my $self  = shift;
534    my $item1 = shift;
535    my $item2 = shift;
536    foreach my $key ( grep { /:/ } keys %$item2 ) {
537        next if ( $key =~ /^-?(dc|rdf|xmlns):/ );
538
539        # deep copy would be better
540        $item1->{$key} = $item2->{$key};
541    }
542}
543
544sub normalize {
545    my $self = shift;
546    $self->normalize_pubDate();
547    $self->sort_item();
548    $self->uniq_item();
549}
550
551sub normalize_pubDate {
552    my $self = shift;
553    foreach my $item ( $self->get_item() ) {
554        my $date = $item->get_pubDate_native() or next;
555        $item->pubDate( $date );
556    }
557    my $date = $self->get_pubDate_native();
558    $self->pubDate( $date ) if $date;
559}
560
561sub xmlns {
562    my $self = shift;
563    my $ns   = shift;
564    my $url  = shift;
565    my $root = $self->docroot;
566    if ( !defined $ns ) {
567        my $list = [ grep { /^-xmlns(:\S|$)/ } keys %$root ];
568        return map { (/^-(.*)$/)[0] } @$list;
569    }
570    elsif ( !defined $url ) {
571        return unless exists $root->{ '-' . $ns };
572        return $root->{ '-' . $ns };
573    }
574    else {
575        $root->{ '-' . $ns } = $url;
576    }
577}
578
579sub get_pubDate_w3cdtf {
580    my $self = shift;
581    my $date = $self->get_pubDate_native();
582    XML::FeedPP::Util::get_w3cdtf($date);
583}
584
585sub get_pubDate_rfc1123 {
586    my $self = shift;
587    my $date = $self->get_pubDate_native();
588    XML::FeedPP::Util::get_rfc1123($date);
589}
590
591sub call {
592    my $self = shift;
593    my $name = shift;
594    my $class = __PACKAGE__."::Plugin::".$name;
595    my $pmfile = $class;
596    $pmfile =~ s#::#/#g;
597    $pmfile .= ".pm";
598    local $@;
599    eval {
600        require $pmfile;
601    } unless defined $class->VERSION;
602    Carp::croak "$class failed: $@" if $@;
603    return $class->run( $self, @_ );
604}
605
606# ----------------------------------------------------------------
607package XML::FeedPP::Plugin;
608use strict;
609
610sub run {
611    my $class = shift;
612    my $feed = shift;
613    my $ref = ref $class ? ref $class : $class;
614    Carp::croak $ref."->run() is not implemented";
615}
616
617# ----------------------------------------------------------------
618package XML::FeedPP::Item;
619use strict;
620use vars qw( @ISA );
621@ISA = qw( XML::FeedPP::Element );
622
623*get_pubDate_w3cdtf  = \&XML::FeedPP::get_pubDate_w3cdtf;   # import
624*get_pubDate_rfc1123 = \&XML::FeedPP::get_pubDate_rfc1123;
625
626# ----------------------------------------------------------------
627package XML::FeedPP::RSS;
628use strict;
629use vars qw( @ISA );
630@ISA = qw( XML::FeedPP );
631
632sub new {
633    my $package = shift;
634    my $source  = shift;
635    my $self    = {};
636    bless $self, $package;
637    if ( defined $source ) {
638        $self->load($source, @_);
639        if ( !ref $self || !ref $self->{rss} ) {
640            Carp::croak "Invalid RSS format: $source";
641        }
642    }
643    $self->init_feed();
644    $self;
645}
646
647sub init_feed {
648    my $self = shift or return;
649
650    $self->{rss}               ||= {};
651    $self->{rss}->{'-version'} ||= $RSS_VERSION;
652
653    $self->{rss}->{channel} ||= XML::FeedPP::Element->new();
654    XML::FeedPP::Element->ref_bless( $self->{rss}->{channel} );
655
656    $self->{rss}->{channel}->{item} ||= [];
657    if ( UNIVERSAL::isa( $self->{rss}->{channel}->{item}, "HASH" ) ) {
658
659        # only one item
660        $self->{rss}->{channel}->{item} = [ $self->{rss}->{channel}->{item} ];
661    }
662    foreach my $item ( @{ $self->{rss}->{channel}->{item} } ) {
663        XML::FeedPP::RSS::Item->ref_bless($item);
664    }
665
666    $self;
667}
668
669sub merge_native_channel {
670    my $self = shift;
671    my $tree = shift;
672
673    XML::FeedPP::Util::merge_hash( $self->{rss}, $tree->{rss}, qw( channel ) );
674    XML::FeedPP::Util::merge_hash(
675        $self->{rss}->{channel},
676        $tree->{rss}->{channel},
677        qw( item )
678    );
679}
680
681sub add_item {
682    my $self = shift;
683    my $link = shift;
684
685    Carp::croak "add_item needs a argument" unless defined $link;
686    if ( ref $link ) {
687        return $self->add_clone_item( $link );
688    }
689
690    my $item = XML::FeedPP::RSS::Item->new();
691    $item->link($link);
692    push( @{ $self->{rss}->{channel}->{item} }, $item );
693    $item;
694}
695
696sub clear_item {
697    my $self = shift;
698    $self->{rss}->{channel}->{item} = [];
699}
700
701sub remove_item {
702    my $self   = shift;
703    my $remove = shift;
704    my $list   = $self->{rss}->{channel}->{item} or return;
705    my @deleted;
706
707    if ( $remove =~ /^\d+/ ) {
708        @deleted = splice( @$list, $remove, 1 );
709    }
710    else {
711        @deleted = grep { $_->link() eq $remove } @$list;
712        @$list = grep { $_->link() ne $remove } @$list;
713    }
714
715    wantarray ? @deleted : shift @deleted;
716}
717
718sub get_item {
719    my $self = shift;
720    my $num  = shift;
721    $self->{rss}->{channel}->{item} ||= [];
722    if ( defined $num ) {
723        return $self->{rss}->{channel}->{item}->[$num];
724    }
725    elsif (wantarray) {
726        return @{ $self->{rss}->{channel}->{item} };
727    }
728    else {
729        return scalar @{ $self->{rss}->{channel}->{item} };
730    }
731}
732
733sub sort_item {
734    my $self = shift;
735    my $list = $self->{rss}->{channel}->{item} or return;
736    my @http = map { exists $_->{pubDate} ? $_->{pubDate} : "" } @$list;
737    my @w3c  = map { exists $_->{pubDate} ? $_->pubDate() : "" } @$list;
738    my %cache;
739    @cache{@http} = @w3c;
740    @$list = sort {
741             exists $a->{pubDate}
742          && exists $b->{pubDate}
743          && $cache{ $b->{pubDate} } cmp $cache{ $a->{pubDate} }
744    } @$list;
745}
746
747sub uniq_item {
748    my $self  = shift;
749    my $list  = $self->{rss}->{channel}->{item} or return;
750    my $check = {};
751    my $uniq  = [];
752    foreach my $item (@$list) {
753        my $link = $item->link();
754        push( @$uniq, $item ) unless $check->{$link}++;
755    }
756    @$list = @$uniq;
757}
758
759sub limit_item {
760    my $self  = shift;
761    my $limit = shift;
762    my $list  = $self->{rss}->{channel}->{item} or return;
763    $#$list = $limit - 1 if ( $limit < scalar @$list );
764    scalar @$list;
765}
766
767sub docroot { shift->{rss}; }
768sub channel { shift->{rss}->{channel}; }
769sub set     { shift->{rss}->{channel}->set(@_); }
770sub get     { shift->{rss}->{channel}->get(@_); }
771
772sub title       { shift->{rss}->{channel}->get_or_set( "title",       @_ ); }
773sub description { shift->{rss}->{channel}->get_or_set( "description", @_ ); }
774sub link        { shift->{rss}->{channel}->get_or_set( "link",        @_ ); }
775sub language    { shift->{rss}->{channel}->get_or_set( "language",    @_ ); }
776sub copyright   { shift->{rss}->{channel}->get_or_set( "copyright",   @_ ); }
777
778sub pubDate {
779    my $self = shift;
780    my $date = shift;
781    return $self->get_pubDate_w3cdtf() unless defined $date;
782    $date = XML::FeedPP::Util::get_rfc1123($date);
783    $self->{rss}->{channel}->set_value( "pubDate", $date );
784}
785
786sub get_pubDate_native {
787    my $self = shift;
788    $self->{rss}->{channel}->get_value("pubDate")       # normal RSS 2.0
789    || $self->{rss}->{channel}->get_value("dc:date");   # strange
790}
791
792sub image {
793    my $self = shift;
794    my $url  = shift;
795    if ( defined $url ) {
796        my ( $title, $link, $desc, $width, $height ) = @_;
797        $self->{rss}->{channel}->{image} ||= {};
798        my $image = $self->{rss}->{channel}->{image};
799        $image->{url}         = $url;
800        $image->{title}       = $title if defined $title;
801        $image->{link}        = $link if defined $link;
802        $image->{description} = $desc if defined $desc;
803        $image->{width}       = $width if defined $width;
804        $image->{height}      = $height if defined $height;
805    }
806    elsif ( exists $self->{rss}->{channel}->{image} ) {
807        my $image = $self->{rss}->{channel}->{image};
808        my $array = [];
809        foreach my $key (qw( url title link description width height )) {
810            push( @$array, exists $image->{$key} ? $image->{$key} : undef );
811        }
812        return wantarray ? @$array : shift @$array;
813    }
814    undef;
815}
816
817# ----------------------------------------------------------------
818package XML::FeedPP::RSS::Item;
819use strict;
820use vars qw( @ISA );
821@ISA = qw( XML::FeedPP::Item );
822
823sub title       { shift->get_or_set( "title",       @_ ); }
824sub description { shift->get_or_set( "description", @_ ); }
825sub category    { shift->get_set_array( "category", @_ ); }
826sub author      { shift->get_or_set( "author",      @_ ); }
827
828sub link {
829    my $self = shift;
830    my $link = shift;
831    return $self->get_value("link") unless defined $link;
832    $self->guid($link)              unless defined $self->guid();
833    $self->set_value( link => $link );
834}
835
836sub guid {
837    my $self = shift;
838    my $guid = shift;
839    return $self->get_value("guid") unless defined $guid;
840    my $perma = shift || "true";
841    $self->set_value( guid => $guid, isPermaLink => $perma );
842}
843
844sub pubDate {
845    my $self = shift;
846    my $date = shift;
847    return $self->get_pubDate_w3cdtf() unless defined $date;
848    $date = XML::FeedPP::Util::get_rfc1123($date);
849    $self->set_value( "pubDate", $date );
850}
851
852sub get_pubDate_native {
853    my $self = shift;
854    $self->get_value("pubDate")         # normal RSS 2.0
855    || $self->get_value("dc:date");     # strange
856}
857
858sub image {
859    my $self = shift;
860    my $url  = shift;
861    if ( defined $url ) {
862        my ( $title, $link, $desc, $width, $height ) = @_;
863        $self->{image} ||= {};
864        my $image = $self->{image};
865        $image->{url}         = $url;
866        $image->{title}       = $title if defined $title;
867        $image->{link}        = $link if defined $link;
868        $image->{description} = $desc if defined $desc;
869        $image->{width}       = $width if defined $width;
870        $image->{height}      = $height if defined $height;
871    }
872    elsif ( exists $self->{image} ) {
873        my $image = $self->{image};
874        my $array = [];
875        foreach my $key (qw( url title link description width height )) {
876            push( @$array, exists $image->{$key} ? $image->{$key} : undef );
877        }
878        return wantarray ? @$array : shift @$array;
879    }
880    undef;
881}
882
883# ----------------------------------------------------------------
884package XML::FeedPP::RDF;
885use strict;
886use vars qw( @ISA );
887@ISA = qw( XML::FeedPP );
888
889sub new {
890    my $package = shift;
891    my $source  = shift;
892    my $self    = {};
893    bless $self, $package;
894    if ( defined $source ) {
895        $self->load($source, @_);
896        if ( !ref $self || !ref $self->{'rdf:RDF'} ) {
897            Carp::croak "Invalid RDF format: $source";
898        }
899    }
900    $self->init_feed();
901    $self;
902}
903
904sub init_feed {
905    my $self = shift or return;
906
907    $self->{'rdf:RDF'} ||= {};
908    $self->xmlns( 'xmlns'     => $XMLNS_RSS );
909    $self->xmlns( 'xmlns:rdf' => $XMLNS_RDF );
910    $self->xmlns( 'xmlns:dc'  => $XMLNS_DC );
911
912    $self->{'rdf:RDF'}->{channel} ||= XML::FeedPP::Element->new();
913    XML::FeedPP::Element->ref_bless( $self->{'rdf:RDF'}->{channel} );
914
915    $self->{'rdf:RDF'}->{channel}->{items}              ||= {};
916    $self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'} ||= {};
917
918    my $rdfseq = $self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'};
919    $rdfseq->{'rdf:li'} ||= [];
920    if ( UNIVERSAL::isa( $rdfseq->{'rdf:li'}, "HASH" ) ) {
921        $rdfseq->{'rdf:li'} = [ $rdfseq->{'rdf:li'} ];
922    }
923    $self->{'rdf:RDF'}->{item} ||= [];
924    if ( UNIVERSAL::isa( $self->{'rdf:RDF'}->{item}, "HASH" ) ) {
925
926        # force array when only one item exist
927        $self->{'rdf:RDF'}->{item} = [ $self->{'rdf:RDF'}->{item} ];
928    }
929    foreach my $item ( @{ $self->{'rdf:RDF'}->{item} } ) {
930        XML::FeedPP::RDF::Item->ref_bless($item);
931    }
932
933    $self;
934}
935
936sub merge_native_channel {
937    my $self = shift;
938    my $tree = shift;
939
940    XML::FeedPP::Util::merge_hash( $self->{'rdf:RDF'}, $tree->{'rdf:RDF'},
941        qw( channel item ) );
942    XML::FeedPP::Util::merge_hash(
943        $self->{'rdf:RDF'}->{channel},
944        $tree->{'rdf:RDF'}->{channel},
945        qw( items )
946    );
947}
948
949sub add_item {
950    my $self = shift;
951    my $link = shift;
952
953    Carp::croak "add_item needs a argument" unless defined $link;
954    if ( ref $link ) {
955        return $self->add_clone_item( $link );
956    }
957
958    my $rdfli = XML::FeedPP::Element->new();
959    $rdfli->{'-rdf:resource'} = $link;
960    $self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'}->{'rdf:li'} ||= [];
961    push(
962        @{ $self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'}->{'rdf:li'} },
963        $rdfli
964    );
965
966    my $item = XML::FeedPP::RDF::Item->new(@_);
967    $item->link($link);
968    push( @{ $self->{'rdf:RDF'}->{item} }, $item );
969
970    $item;
971}
972
973sub clear_item {
974    my $self = shift;
975    $self->{'rdf:RDF'}->{item} = [];
976    $self->__refresh_items();
977}
978
979sub remove_item {
980    my $self   = shift;
981    my $remove = shift;
982    my $list   = $self->{'rdf:RDF'}->{item} or return;
983    my @deleted;
984
985    if ( $remove =~ /^\d+/ ) {
986        @deleted = splice( @$list, $remove, 1 );
987    }
988    else {
989        @deleted = grep { $_->link() eq $remove } @$list;
990        @$list = grep { $_->link() ne $remove } @$list;
991    }
992
993    $self->__refresh_items();
994
995    wantarray ? @deleted : shift @deleted;
996}
997
998sub get_item {
999    my $self = shift;
1000    my $num  = shift;
1001    $self->{'rdf:RDF'}->{item} ||= [];
1002    if ( defined $num ) {
1003        return $self->{'rdf:RDF'}->{item}->[$num];
1004    }
1005    elsif (wantarray) {
1006        return @{ $self->{'rdf:RDF'}->{item} };
1007    }
1008    else {
1009        return scalar @{ $self->{'rdf:RDF'}->{item} };
1010    }
1011}
1012
1013sub sort_item {
1014    my $self = shift;
1015    my $list = $self->{'rdf:RDF'}->{item} or return;
1016    $list = [
1017        sort {
1018                 exists $a->{"dc:date"}
1019              && exists $b->{"dc:date"}
1020              && $b->{"dc:date"} cmp $a->{"dc:date"}
1021          } @$list
1022    ];
1023    $self->{'rdf:RDF'}->{item} = $list;
1024    $self->__refresh_items();
1025}
1026
1027sub uniq_item {
1028    my $self  = shift;
1029    my $list  = $self->{'rdf:RDF'}->{item} or return;
1030    my $check = {};
1031    my $uniq  = [];
1032    foreach my $item (@$list) {
1033        my $link = $item->link();
1034        push( @$uniq, $item ) unless $check->{$link}++;
1035    }
1036    $self->{'rdf:RDF'}->{item} = $uniq;
1037    $self->__refresh_items();
1038}
1039
1040sub limit_item {
1041    my $self  = shift;
1042    my $limit = shift;
1043    my $list  = $self->{'rdf:RDF'}->{item} or return;
1044    $#$list = $limit - 1 if ( $limit < scalar @$list );
1045    $self->__refresh_items();
1046}
1047
1048sub __refresh_items {
1049    my $self = shift;
1050    my $list = $self->{'rdf:RDF'}->{item} or return;
1051    $self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'}->{'rdf:li'} = [];
1052    my $dest = $self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'}->{'rdf:li'};
1053    foreach my $item (@$list) {
1054        my $rdfli = XML::FeedPP::Element->new();
1055        $rdfli->{'-rdf:resource'} = $item->link();
1056        push( @$dest, $rdfli );
1057    }
1058    scalar @$dest;
1059}
1060
1061sub docroot { shift->{'rdf:RDF'}; }
1062sub channel { shift->{'rdf:RDF'}->{channel}; }
1063sub set     { shift->{'rdf:RDF'}->{channel}->set(@_); }
1064sub get     { shift->{'rdf:RDF'}->{channel}->get(@_); }
1065sub title       { shift->{'rdf:RDF'}->{channel}->get_or_set( "title", @_ ); }
1066sub description { shift->{'rdf:RDF'}->{channel}->get_or_set( "description", @_ ); }
1067sub language    { shift->{'rdf:RDF'}->{channel}->get_or_set( "dc:language", @_ ); }
1068sub copyright   { shift->{'rdf:RDF'}->{channel}->get_or_set( "dc:rights", @_ ); }
1069
1070sub link {
1071    my $self = shift;
1072    my $link = shift;
1073    return $self->{'rdf:RDF'}->{channel}->get_value("link")
1074      unless defined $link;
1075    $self->{'rdf:RDF'}->{channel}->{'-rdf:about'} = $link;
1076    $self->{'rdf:RDF'}->{channel}->set_value( "link", $link, @_ );
1077}
1078
1079sub pubDate {
1080    my $self = shift;
1081    my $date = shift;
1082    return $self->get_pubDate_w3cdtf() unless defined $date;
1083    $date = XML::FeedPP::Util::get_w3cdtf($date);
1084    $self->{'rdf:RDF'}->{channel}->set_value( "dc:date", $date );
1085}
1086
1087sub get_pubDate_native {
1088    shift->{'rdf:RDF'}->{channel}->get_value("dc:date");
1089}
1090
1091*get_pubDate_w3cdtf = \&get_pubDate_native;
1092
1093sub image {
1094    my $self = shift;
1095    my $url  = shift;
1096    if ( defined $url ) {
1097        my ( $title, $link ) = @_;
1098        $self->{'rdf:RDF'}->{channel}->{image} ||= {};
1099        $self->{'rdf:RDF'}->{channel}->{image}->{'-rdf:resource'} = $url;
1100        $self->{'rdf:RDF'}->{image} ||= {};
1101        $self->{'rdf:RDF'}->{image}->{'-rdf:about'} = $url; # fix
1102        my $image = $self->{'rdf:RDF'}->{image};
1103        $image->{url}   = $url;
1104        $image->{title} = $title if defined $title;
1105        $image->{link}  = $link if defined $link;
1106    }
1107    elsif ( exists $self->{'rdf:RDF'}->{image} ) {
1108        my $image = $self->{'rdf:RDF'}->{image};
1109        my $array = [];
1110        foreach my $key (qw( url title link )) {
1111            push( @$array, exists $image->{$key} ? $image->{$key} : undef );
1112        }
1113        return wantarray ? @$array : shift @$array;
1114    }
1115    elsif ( exists $self->{'rdf:RDF'}->{channel}->{image} ) {
1116        return $self->{'rdf:RDF'}->{channel}->{image}->{'-rdf:resource'};
1117    }
1118    undef;
1119}
1120
1121# ----------------------------------------------------------------
1122package XML::FeedPP::RDF::Item;
1123use strict;
1124use vars qw( @ISA );
1125@ISA = qw( XML::FeedPP::Item );
1126
1127sub title       { shift->get_or_set( "title",       @_ ); }
1128sub description { shift->get_or_set( "description", @_ ); }
1129sub category    { shift->get_set_array( "dc:subject",  @_ ); }
1130sub author      { shift->get_or_set( "creator",     @_ ); }
1131sub guid { undef; }    # this element is NOT supported for RDF
1132
1133sub link {
1134    my $self = shift;
1135    my $link = shift;
1136    return $self->get_value("link") unless defined $link;
1137    $self->{'-rdf:about'} = $link;
1138    $self->set_value( "link", $link, @_ );
1139}
1140
1141sub pubDate {
1142    my $self = shift;
1143    my $date = shift;
1144    return $self->get_pubDate_w3cdtf() unless defined $date;
1145    $date = XML::FeedPP::Util::get_w3cdtf($date);
1146    $self->set_value( "dc:date", $date );
1147}
1148
1149sub get_pubDate_native {
1150    shift->get_value("dc:date");
1151}
1152
1153*get_pubDate_w3cdtf = \&get_pubDate_native;
1154
1155# ----------------------------------------------------------------
1156package XML::FeedPP::Atom;
1157use strict;
1158use vars qw( @ISA );
1159@ISA = qw( XML::FeedPP );
1160
1161sub new {
1162    my $package = shift;
1163    my $source  = shift;
1164    my $self    = {};
1165    bless $self, $package;
1166    if ( defined $source ) {
1167        $self->load($source, @_);
1168        if ( !ref $self || !ref $self->{feed} ) {
1169            Carp::croak "Invalid Atom format: $source";
1170        }
1171    }
1172    $self->init_feed();
1173    $self;
1174}
1175
1176sub init_feed {
1177    my $self = shift or return;
1178
1179    $self->{feed} ||= XML::FeedPP::Element->new();
1180    XML::FeedPP::Element->ref_bless( $self->{feed} );
1181
1182    $self->xmlns( 'xmlns' => $XMLNS_ATOM );
1183    $self->{feed}->{'-version'} ||= $ATOM_VERSION;
1184
1185    $self->{feed}->{entry} ||= [];
1186    if ( UNIVERSAL::isa( $self->{feed}->{entry}, "HASH" ) ) {
1187        # if this feed has only one item
1188        $self->{feed}->{entry} = [ $self->{feed}->{entry} ];
1189    }
1190    foreach my $item ( @{ $self->{feed}->{entry} } ) {
1191        XML::FeedPP::Atom::Entry->ref_bless($item);
1192    }
1193    $self->{feed}->{author} ||= { name => "-" };    # dummy for validation
1194    $self;
1195}
1196
1197sub merge_native_channel {
1198    my $self = shift;
1199    my $tree = shift;
1200
1201    XML::FeedPP::Util::merge_hash( $self->{feed}, $tree->{feed}, qw( entry ) );
1202}
1203
1204sub add_item {
1205    my $self = shift;
1206    my $link = shift;
1207
1208    Carp::croak "add_item needs a argument" unless defined $link;
1209    if ( ref $link ) {
1210        return $self->add_clone_item( $link );
1211    }
1212
1213    my $item = XML::FeedPP::Atom::Entry->new(@_);
1214    $item->link($link);
1215    push( @{ $self->{feed}->{entry} }, $item );
1216
1217    $item;
1218}
1219
1220sub clear_item {
1221    my $self = shift;
1222    $self->{feed}->{entry} = [];
1223}
1224
1225sub remove_item {
1226    my $self   = shift;
1227    my $remove = shift;
1228    my $list   = $self->{feed}->{entry} or return;
1229    my @deleted;
1230
1231    if ( $remove =~ /^\d+/ ) {
1232        @deleted = splice( @$list, $remove, 1 );
1233    }
1234    else {
1235        @deleted = grep { $_->link() eq $remove } @$list;
1236        @$list = grep { $_->link() ne $remove } @$list;
1237    }
1238
1239    wantarray ? @deleted : shift @deleted;
1240}
1241
1242sub get_item {
1243    my $self = shift;
1244    my $num  = shift;
1245    $self->{feed}->{entry} ||= [];
1246    if ( defined $num ) {
1247        return $self->{feed}->{entry}->[$num];
1248    }
1249    elsif (wantarray) {
1250        return @{ $self->{feed}->{entry} };
1251    }
1252    else {
1253        return scalar @{ $self->{feed}->{entry} };
1254    }
1255}
1256
1257sub sort_item {
1258    my $self = shift;
1259    my $list = $self->{feed}->{entry} or return;
1260    $list = [
1261        sort {
1262                 exists $a->{issued}
1263              && exists $b->{issued}
1264              && $b->{issued} cmp $a->{issued}
1265          } @$list
1266    ];
1267    $self->{feed}->{entry} = $list;
1268    scalar @$list;
1269}
1270
1271sub uniq_item {
1272    my $self  = shift;
1273    my $list  = $self->{feed}->{entry} or return;
1274    my $check = {};
1275    my $uniq  = [];
1276    foreach my $item (@$list) {
1277        my $link = $item->link();
1278        push( @$uniq, $item ) unless $check->{$link}++;
1279    }
1280    @$list = @$uniq;
1281}
1282
1283sub limit_item {
1284    my $self  = shift;
1285    my $limit = shift;
1286    my $list  = $self->{feed}->{entry} or return;
1287    $#$list = $limit - 1 if ( $limit < scalar @$list );
1288    scalar @$list;
1289}
1290
1291sub docroot { shift->{feed}; }
1292sub channel { shift->{feed}; }
1293sub set     { shift->{feed}->set(@_); }
1294sub get     { shift->{feed}->get(@_); }
1295
1296sub title {
1297    my $self  = shift;
1298    my $title = shift;
1299    return $self->{feed}->get_value("title") unless defined $title;
1300    $self->{feed}->set_value( "title" => $title, type => "text/plain" );
1301}
1302
1303sub description {
1304    my $self = shift;
1305    my $desc = shift;
1306    return $self->{feed}->get_value("tagline")
1307        || $self->{feed}->get_value("subtitle") unless defined $desc;
1308    $self->{feed}->set_value( "tagline" => $desc, type => "text/html", mode => "escaped" );
1309}
1310
1311sub link {
1312    my $self = shift;
1313    my $href = shift;
1314
1315    my $link = $self->{feed}->{link} || [];
1316    $link = [$link] if UNIVERSAL::isa( $link, "HASH" );
1317    $link = [ grep { ref $_ } @$link ];
1318    $link = [ grep {
1319        ! exists $_->{'-rel'} || $_->{'-rel'} eq 'alternate'
1320    } @$link ];
1321    $link = [ grep {
1322        ! exists $_->{'-type'} || $_->{'-type'} =~ m#^text/(x-)?html#i
1323    } @$link ];
1324    my $html = shift @$link;
1325
1326    if ( defined $href ) {
1327        if ( ref $html ) {
1328            $html->{'-href'} = $href;
1329        }
1330        else {
1331            my $hash = {
1332                -rel    =>  'alternate',
1333                -type   =>  'text/html',
1334                -href   =>  $href,
1335            };
1336            my $flink = $self->{feed}->{link};
1337            if ( ! ref $flink ) {
1338                $self->{feed}->{link} = [ $hash ];
1339            }
1340            elsif ( UNIVERSAL::isa( $flink, 'ARRAY' )) {
1341                push( @$flink, $hash );
1342            }
1343            elsif ( UNIVERSAL::isa( $flink, 'HASH' )) {
1344                $self->{feed}->{link} = [ $flink, $hash ];
1345            }
1346        }
1347    }
1348    elsif ( ref $html ) {
1349        return $html->{'-href'};
1350    }
1351    return;
1352}
1353
1354sub pubDate {
1355    my $self = shift;
1356    my $date = shift;
1357    return $self->get_pubDate_w3cdtf() unless defined $date;
1358    $date = XML::FeedPP::Util::get_w3cdtf($date);
1359    $self->{feed}->set_value( "modified", $date );
1360}
1361
1362sub get_pubDate_native {
1363    my $self = shift;
1364    $self->{feed}->get_value("modified")        # Atom 0.3
1365    || $self->{feed}->get_value("updated");     # Atom 1.0
1366}
1367
1368*get_pubDate_w3cdtf = \&get_pubDate_native;
1369
1370sub language {
1371    my $self = shift;
1372    my $lang = shift;
1373    return $self->{feed}->{'-xml:lang'} unless defined $lang;
1374    $self->{feed}->{'-xml:lang'} = $lang;
1375}
1376
1377sub copyright {
1378    shift->{feed}->get_or_set( "copyright" => @_ );
1379}
1380
1381sub image {
1382    my $self = shift;
1383    my $href = shift;
1384    my $title = shift;
1385
1386    my $link = $self->{feed}->{link} || [];
1387    $link = [$link] if UNIVERSAL::isa( $link, "HASH" );
1388    my $icon = (
1389        grep {
1390               ref $_
1391            && exists $_->{'-rel'}
1392            && ($_->{'-rel'} eq "icon" )
1393        } @$link
1394    )[0];
1395
1396    my $MIME_TYPES = { reverse qw(
1397        image/bmp                       bmp
1398        image/gif                       gif
1399        image/jpeg                      jpeg
1400        image/jpeg                      jpg
1401        image/png                       png
1402        image/svg+xml                   svg
1403        image/x-icon                    ico
1404        image/x-xbitmap                 xbm
1405        image/x-xpixmap                 xpm
1406    )};
1407    my $rext = join( "|", map {"\Q$_\E"} keys %$MIME_TYPES );
1408
1409    if ( defined $href ) {
1410        my $ext = ( $href =~ m#[^/]\.($rext)(\W|$)#i )[0];
1411        my $type = $MIME_TYPES->{$ext} if $ext;
1412
1413        if ( ref $icon ) {
1414            $icon->{'-href'}  = $href;
1415            $icon->{'-type'}  = $type if $type;
1416            $icon->{'-title'} = $title if $title;
1417        }
1418        else {
1419            my $newicon = {};
1420            $newicon->{'-rel'}   = 'icon';
1421            $newicon->{'-href'}  = $href;
1422            $newicon->{'-type'}  = $type if $type;
1423            $newicon->{'-title'} = $title if $title;
1424            my $flink = $self->{feed}->{link};
1425            if ( UNIVERSAL::isa( $flink, "ARRAY" )) {
1426                push( @$flink, $newicon );
1427            }
1428            elsif ( UNIVERSAL::isa( $flink, "HASH" )) {
1429                $self->{feed}->{link} = [ $flink, $newicon ];
1430            }
1431            else {
1432                $self->{feed}->{link} = [ $newicon ];
1433            }
1434        }
1435    }
1436    elsif ( ref $icon ) {
1437        my $array = [ $icon->{'-href'} ];
1438        push( @$array, $icon->{'-title'} ) if exists $icon->{'-title'};
1439        return wantarray ? @$array : shift @$array;
1440    }
1441    undef;
1442}
1443# ----------------------------------------------------------------
1444package XML::FeedPP::Atom::Entry;
1445use strict;
1446use vars qw( @ISA );
1447@ISA = qw( XML::FeedPP::Item );
1448
1449sub title {
1450    my $self  = shift;
1451    my $title = shift;
1452    return $self->get_value("title") unless defined $title;
1453    $self->set_value( "title" => $title, type => "text/plain" );
1454}
1455
1456sub description {
1457    my $self = shift;
1458    my $desc = shift;
1459    return $self->get_value('summary')
1460        || $self->get_value('content') unless defined $desc;
1461    $self->set_value(
1462        'content' => $desc,
1463        type      => 'text/html',
1464        mode      => 'escaped'
1465    );
1466}
1467
1468sub link {
1469    my $self = shift;
1470    my $href = shift;
1471
1472    my $link = $self->{link} || [];
1473    $link = [$link] if UNIVERSAL::isa( $link, "HASH" );
1474    $link = [ grep { ref $_ } @$link ];
1475    $link = [ grep {
1476        ! exists $_->{'-rel'} || $_->{'-rel'} eq 'alternate'
1477    } @$link ];
1478    $link = [ grep {
1479        ! exists $_->{'-type'} || $_->{'-type'} =~ m#^text/(x-)?html#i
1480    } @$link ];
1481    my $html = shift @$link;
1482
1483    if ( defined $href ) {
1484        if ( ref $html ) {
1485            $html->{'-href'} = $href;
1486        }
1487        else {
1488            my $hash = {
1489                -rel    =>  'alternate',
1490                -type   =>  'text/html',
1491                -href   =>  $href,
1492            };
1493            my $flink = $self->{link};
1494            if ( ! ref $flink ) {
1495                $self->{link} = [ $hash ];
1496            }
1497            elsif ( ref $flink && UNIVERSAL::isa( $flink, 'ARRAY' )) {
1498                push( @$flink, $hash );
1499            }
1500            elsif ( ref $flink && UNIVERSAL::isa( $flink, 'HASH' )) {
1501                $self->{link} = [ $flink, $hash ];
1502            }
1503        }
1504        $self->guid( $href ) unless defined $self->guid();
1505    }
1506    elsif ( ref $html ) {
1507        return $html->{'-href'};
1508    }
1509    return;
1510}
1511
1512sub pubDate {
1513    my $self = shift;
1514    my $date = shift;
1515    return $self->get_pubDate_w3cdtf() unless defined $date;
1516    $date = XML::FeedPP::Util::get_w3cdtf($date);
1517    $self->set_value( "issued",   $date );
1518    $self->set_value( "modified", $date );
1519}
1520
1521sub get_pubDate_native {
1522    my $self = shift;
1523    $self->get_value("issued")          # Atom 0.3
1524    || $self->get_value("modified")     # Atom 0.3
1525    || $self->get_value("updated");     # Atom 1.0
1526}
1527
1528*get_pubDate_w3cdtf = \&get_pubDate_native;
1529
1530sub author {
1531    my $self = shift;
1532    my $name = shift;
1533    unless ( defined $name ) {
1534        my $author = $self->{author}->{name} if ref $self->{author};
1535        return $author;
1536    }
1537    my $author = ref $name ? $name : { name => $name };
1538    $self->{author} = $author;
1539}
1540
1541sub guid { shift->get_or_set( "id", @_ ); }
1542sub category { undef; }    # this element is NOT supported for Atom
1543
1544# ----------------------------------------------------------------
1545package XML::FeedPP::Element;
1546use strict;
1547
1548sub new {
1549    my $package = shift;
1550    my $self    = {@_};
1551    bless $self, $package;
1552    $self;
1553}
1554
1555sub ref_bless {
1556    my $package = shift;
1557    my $self    = shift;
1558    bless $self, $package;
1559    $self;
1560}
1561
1562sub set {
1563    my $self = shift;
1564
1565    while ( scalar @_ ) {
1566        my $key  = shift @_;
1567        my $val  = shift @_;
1568        my $node = $self;
1569        while ( $key =~ s#^([^/]+)/##s ) {
1570            my $child = $1;
1571            if ( ref $node->{$child} ) {
1572                # ok
1573            }
1574            elsif ( defined $node->{$child} ) {
1575                $node->{$child} = { "#text" => $node->{$child} };
1576            }
1577            else {
1578                $node->{$child} = {};
1579            }
1580            $node = $node->{$child};
1581        }
1582        my ( $tagname, $attr ) = split( /\@/, $key, 2 );
1583        if ( $tagname eq "" && defined $attr ) {
1584            $node->{ '-' . $attr } = $val;
1585        }
1586        elsif ( defined $attr ) {
1587            if ( ref $node->{$tagname} ) {
1588                $node->{$tagname}->{ '-' . $attr } = $val;
1589            }
1590            elsif ( defined $node->{$tagname} ) {
1591                $node->{$tagname} = {
1592                    "#text"     => $node->{$tagname},
1593                    '-' . $attr => $val,
1594                };
1595            }
1596            else {
1597                $node->{$tagname} = { '-' . $attr => $val, };
1598            }
1599        }
1600        elsif ( defined $tagname ) {
1601            if ( ref $self->{$tagname} ) {
1602                $node->{$tagname}->{'#text'} = $val;
1603            }
1604            else {
1605                $node->{$tagname} = $val;
1606            }
1607        }
1608    }
1609}
1610
1611sub get {
1612    my $self = shift;
1613    my $key  = shift;
1614    my $node = $self;
1615
1616    while ( $key =~ s#^([^/]+)/##s ) {
1617        my $child = $1;
1618        return unless ref $node;
1619        return unless exists $node->{$child};
1620        $node = $node->{$child};
1621    }
1622    my ( $tagname, $attr ) = split( /\@/, $key, 2 );
1623    return unless ref $node;
1624    return unless exists $node->{$tagname};
1625    if ( defined $attr ) {    # attribute
1626        return unless ref $node->{$tagname};
1627        return unless exists $node->{$tagname}->{ '-' . $attr };
1628        return $node->{$tagname}->{ '-' . $attr };
1629    }
1630    else {                    # node value
1631        return $node->{$tagname} unless ref $node->{$tagname};
1632        return $node->{$tagname}->{'#text'};
1633    }
1634}
1635
1636sub get_set_array {
1637    my $self = shift;
1638    my $elem = shift;
1639    my $value = shift;
1640    if ( defined $value ) {
1641        $value = [ $value, @_ ] if scalar @_;
1642        $self->{$elem} = $value;
1643    } else {
1644        return unless exists $self->{$elem};
1645        return $self->{$elem};
1646    }
1647}
1648
1649sub get_or_set {
1650    my $self = shift;
1651    my $elem = shift;
1652    return scalar @_
1653      ? $self->set_value( $elem, @_ )
1654      : $self->get_value($elem);
1655}
1656
1657sub get_value {
1658    my $self = shift;
1659    my $elem = shift;
1660    return unless exists $self->{$elem};
1661    return $self->{$elem} unless ref $self->{$elem};
1662    return $self->{$elem}->{'#text'} if exists $self->{$elem}->{'#text'};
1663    # a hack for atom: <content type="xhtml"><div>...</div></content>
1664    my $child = [ grep { /^[^\-\#]/ } keys %{$self->{$elem}} ];
1665    if ( exists $self->{$elem}->{'-type'}
1666        && ($self->{$elem}->{'-type'} eq "xhtml")
1667        && scalar @$child == 1) {
1668        return &get_value( $self->{$elem}, $child->[0] );
1669    }
1670    return;
1671}
1672
1673sub set_value {
1674    my $self = shift;
1675    my $elem = shift;
1676    my $text = shift;
1677    my $attr = \@_;
1678    if ( ref $self->{$elem} ) {
1679        $self->{$elem}->{'#text'} = $text;
1680    }
1681    else {
1682        $self->{$elem} = $text;
1683    }
1684    $self->set_attr( $elem, @$attr ) if scalar @$attr;
1685    undef;
1686}
1687
1688sub get_attr {
1689    my $self = shift;
1690    my $elem = shift;
1691    my $key  = shift;
1692    return unless exists $self->{$elem};
1693    return unless ref $self->{$elem};
1694    return unless exists $self->{$elem}->{ '-' . $key };
1695    $self->{$elem}->{ '-' . $key };
1696}
1697
1698sub set_attr {
1699    my $self = shift;
1700    my $elem = shift;
1701    my $attr = \@_;
1702    if ( defined $self->{$elem} ) {
1703        if ( !ref $self->{$elem} ) {
1704            $self->{$elem} = { "#text" => $self->{$elem} };
1705        }
1706    }
1707    else {
1708        $self->{$elem} = {};
1709    }
1710    while ( scalar @$attr ) {
1711        my $key = shift @$attr;
1712        my $val = shift @$attr;
1713        if ( defined $val ) {
1714            $self->{$elem}->{ '-' . $key } = $val;
1715        }
1716        else {
1717            delete $self->{$elem}->{ '-' . $key };
1718        }
1719    }
1720    undef;
1721}
1722
1723# ----------------------------------------------------------------
1724package XML::FeedPP::Util;
1725use strict;
1726
1727my ( @DoW, @MoY, %MoY );
1728@DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
1729@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
1730@MoY{ map { uc($_) } @MoY } = ( 1 .. 12 );
1731
1732sub epoch_to_w3cdtf {
1733    my $epoch = shift;
1734    return unless defined $epoch;
1735    my ( $sec, $min, $hour, $day, $mon, $year ) = localtime($epoch);
1736    $year += 1900;
1737    $mon++;
1738    my $off =
1739      ( Time::Local::timegm( localtime($epoch) ) -
1740          Time::Local::timegm( gmtime($epoch) ) ) / 60;
1741    my $tz = $off ? sprintf( "%+03d:%02d", $off / 60, $off % 60 ) : "Z";
1742    sprintf( "%04d-%02d-%02dT%02d:%02d:%02d%s",
1743        $year, $mon, $day, $hour, $min, $sec, $tz );
1744}
1745
1746sub epoch_to_rfc1123 {
1747    my $epoch = shift;
1748    return unless defined $epoch;
1749    my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = localtime($epoch);
1750    $year += 1900;
1751    my $off =
1752      ( Time::Local::timegm( localtime($epoch) ) -
1753          Time::Local::timegm( gmtime($epoch) ) ) / 60;
1754    my $tz = $off ? sprintf( "%+03d%02d", $off / 60, $off % 60 ) : "GMT";
1755    sprintf( "%s, %02d %s %04d %02d:%02d:%02d %s",
1756        $DoW[$wday], $mday, $MoY[$mon], $year, $hour, $min, $sec, $tz );
1757}
1758
1759sub rfc1123_to_w3cdtf {
1760    my $str = shift;
1761    return unless defined $str;
1762    my ( $mday, $mon, $year, $hour, $min, $sec, $tz ) = (
1763        $str =~ m{
1764        ^(?:[A-Za-z]+,\s*)? (\d+)\s+ ([A-Za-z]+)\s+ (\d+)\s+
1765        (\d+):(\d+):(\d+)\s* ([\+\-]\d+:?\d{2})?
1766    }x
1767    );
1768    return unless ( $year && $mon && $mday );
1769    $mon = $MoY{ uc($mon) } or return;
1770    if ( defined $tz && $tz =~ m/^([\+\-]\d+):?(\d{2})$/ ) {
1771        $tz = sprintf( "%+03d:%02d", $1, $2 );
1772    }
1773    else {
1774        $tz = "Z";
1775    }
1776    sprintf( "%04d-%02d-%02dT%02d:%02d:%02d%s",
1777        $year, $mon, $mday, $hour, $min, $sec, $tz );
1778}
1779
1780sub w3cdtf_to_rfc1123 {
1781    my $str = shift;
1782    return unless defined $str;
1783    my ( $year, $mon, $mday, $hour, $min, $sec, $tz ) = (
1784        $str =~ m{
1785        ^(\d+)-(\d+)-(\d+)(?:T(\d+):(\d+)(?::(\d+)(?:\.\d*)?\:?)?([\+\-]\d+:?\d{2})?|$)
1786    }x
1787    );
1788    return unless ( $year > 1900 && $mon && $mday );
1789    $hour ||= 0;
1790    $min ||= 0;
1791    $sec ||= 0;
1792    my $epoch = Time::Local::timegm( $sec, $min, $hour, $mday, $mon-1, $year-1900 );
1793
1794    my $wday = ( gmtime($epoch) )[6];
1795    if ( defined $tz && $tz =~ m/^([\+\-]\d+):?(\d{2})$/ ) {
1796        $tz = sprintf( "%+03d%02d", $1, $2 );
1797    }
1798    else {
1799        $tz = "GMT";
1800    }
1801    sprintf(
1802        "%s, %02d %s %04d %02d:%02d:%02d %s",
1803        $DoW[$wday], $mday, $MoY[ $mon - 1 ],
1804        $year, $hour, $min, $sec, $tz
1805    );
1806}
1807
1808sub get_w3cdtf {
1809    my $date = shift;
1810    return unless defined $date;
1811    if ( $date =~ /^\d+$/s ) {
1812        return &epoch_to_w3cdtf($date);
1813    }
1814    elsif ( $date =~ /^([A-Za-z]+,\s*)?\d+\s+[A-Za-z]+\s+\d+\s+\d+:\d+:\d+/s ) {
1815        return &rfc1123_to_w3cdtf($date);
1816    }
1817    elsif ( $date =~ /^\d{4}-\d{2}-\d{2}(T\d{2}:\d{2}(:\d{2}(\.\d+)?:?)?[Z\+\-]|$)/s ) {
1818        return $date;
1819    }
1820    undef;
1821}
1822
1823sub get_rfc1123 {
1824    my $date = shift;
1825    return unless defined $date;
1826    if ( $date =~ /^\d+$/s ) {
1827        return &epoch_to_rfc1123($date);
1828    }
1829    elsif ( $date =~ /^([A-Za-z]+,\s*)?\d+\s+[A-Za-z]+\s+\d+\s+\d+:\d+:\d+/s ) {
1830        return $date;
1831    }
1832    elsif ( $date =~ /^\d{4}-\d{2}-\d{2}(T\d{2}:\d{2}(:\d{2}(\.\d+)?:?)?[Z\+\-]|$)/s ) {
1833        return &w3cdtf_to_rfc1123($date);
1834    }
1835    undef;
1836}
1837
1838sub merge_hash {
1839    my $base  = shift or return;
1840    my $merge = shift or return;
1841    my $map = { map { $_ => 1 } @_ };
1842    foreach my $key ( keys %$merge ) {
1843        next if exists $map->{$key};
1844        next if exists $base->{$key};
1845        $base->{$key} = $merge->{$key};
1846    }
1847}
1848
1849# ----------------------------------------------------------------
18501;
1851# ----------------------------------------------------------------
Note: See TracBrowser for help on using the browser.