=head1 NAME
XML::FeedPP -- Parse/write/merge/edit RSS/RDF/Atom syndication feeds
=head1 SYNOPSIS
Get an RSS file and parse it:
use XML::FeedPP ();
my $source = 'http://use.perl.org/index.rss';
my $feed = XML::FeedPP->new( $source );
print "Title: ", $feed->title(), "\n";
print "Date: ", $feed->pubDate(), "\n";
foreach my $item ( $feed->get_item() ) {
print "URL: ", $item->link(), "\n";
print "Title: ", $item->title(), "\n";
}
Generate an RDF file and save it:
use XML::FeedPP ();
my $feed = XML::FeedPP::RDF->new();
$feed->title( "use Perl" );
$feed->link( "http://use.perl.org/" );
$feed->pubDate( "Thu, 23 Feb 2006 14:43:43 +0900" );
my $item = $feed->add_item( "http://search.cpan.org/~kawasaki/XML-TreePP-0.02" );
$item->title( "Pure Perl implementation for parsing/writing xml file" );
$item->pubDate( "2006-02-23T14:43:43+09:00" );
$feed->to_file( "index.rdf" );
Convert some RSS/RDF files to Atom format:
use XML::FeedPP ();
my $feed = XML::FeedPP::Atom::Atom10->new(); # create empty atom file
$feed->merge( "rss.xml" ); # load local RSS file
$feed->merge( "http://www.kawa.net/index.rdf" ); # load remote RDF file
my $now = time();
$feed->pubDate( $now ); # touch date
my $atom = $feed->to_string(); # get Atom source code
=head1 DESCRIPTION
C<XML::FeedPP> is an all-purpose syndication utility that parses and
publishes RSS 2.0, RSS 1.0 (RDF), Atom 0.3 and 1.0 feeds.
It allows you to add new content, merge feeds, and convert among
these various formats.
It is a pure Perl implementation and does not require any other
module except for XML::TreePP.
=head1 METHODS FOR FEED
=head2 $feed = XML::FeedPP->new( "index.rss" );
This constructor method creates an C<XML::FeedPP> feed instance. The only
argument is the local filename. The format of $source must be one of
the supported feed formats -- RSS, RDF or Atom -- or execution is
halted.
=head2 $feed = XML::FeedPP->new( "http://use.perl.org/index.rss" );
The URL on the remote web server is also available as the first argument.
L<LWP::UserAgent> is required to download it.
=head2 $feed = XML::FeedPP->new( '<rss version="2.0">...' );
The XML source code is also available as the first argument.
=head2 $feed = XML::FeedPP->new( $source, -type => $type );
The C<-type> argument allows you to specify type of $source
from choice of C<'file'>, C<'url'> or C<'string'>.
=head2 $feed = XML::FeedPP->new( $source, utf8_flag => 1 );
This makes utf8 flag on for all feed elements.
Perl 5.8.1 or later is required to use this.
Note that any other options for C<XML::TreePP> constructor are also
allowed like this. See more detail on L<XML::TreePP>.
=head2 $feed = XML::FeedPP::RSS->new( $source );
This constructor method creates an instance for an RSS 2.0 feed.
The first argument is optional, but must be valid an RSS source if specified.
This method returns an empty instance when $source is undefined.
=head2 $feed = XML::FeedPP::RDF->new( $source );
This constructor method creates an instance for RSS 1.0 (RDF) feed.
The first argument is optional, but must be an RDF source if specified.
This method returns an empty instance when $source is undefined.
=head2 $feed = XML::FeedPP::Atom->new( $source );
This constructor method creates an instance for an Atom 0.3/1.0 feed.
The first argument is optional, but must be an Atom source if specified.
This method returns an empty instance when $source is undefined.
Atom 1.0 feed is also supported since C<XML::FeedPP> version 0.30.
Atom 0.3 is still default, however, future version of this module
would create Atom 1.0 as default.
=head2 $feed = XML::FeedPP::Atom::Atom03->new();
This creates an empty Atom 0.3 instance obviously.
=head2 $feed = XML::FeedPP::Atom::Atom10->new();
This creates an empty Atom 1.0 instance intended.
=head2 $feed = XML::FeedPP::RSS->new( link => $link, title => $tile, ... );
This creates a RSS instance which has C<link>, C<title> elements etc.
=head2 $feed->load( $source );
This method loads an RSS/RDF/Atom file,
much like C<new()> method does.
=head2 $feed->merge( $source );
This method merges an RSS/RDF/Atom file into the existing $feed
instance. Top-level metadata from the imported feed is incorporated
only if missing from the present feed.
=head2 $string = $feed->to_string( $encoding );
This method generates XML source as string and returns it. The output
$encoding is optional, and the default encoding is 'UTF-8'. On Perl
5.8 and later, any encodings supported by the Encode module are
available. On Perl 5.005 and 5.6.1, only four encodings supported by
the Jcode module are available: 'UTF-8', 'Shift_JIS', 'EUC-JP' and
'ISO-2022-JP'. 'UTF-8' is recommended for overall compatibility.
=head2 $string = $feed->to_string( indent => 4 );
This makes the output more human readable by indenting appropriately.
This does not strictly follow the XML specification but does looks nice.
Note that any other options for C<XML::TreePP> constructor are also
allowed like this. See more detail on L<XML::TreePP>.
=head2 $feed->to_file( $filename, $encoding );
This method generate an XML file. The output $encoding is optional,
and the default is 'UTF-8'.
=head2 $item = $feed->add_item( $link );
This method creates a new item/entry and returns its instance.
A mandatory $link argument is the URL of the new item/entry.
=head2 $item = $feed->add_item( $srcitem );
This method duplicates an item/entry and adds it to $feed.
$srcitem is a C<XML::FeedPP::*::Item> class's instance
which is returned by C<get_item()> method, as described above.
=head2 $item = $feed->add_item( link => $link, title => $tile, ... );
This method creates an new item/entry
which has C<link>, C<title> elements etc.
=head2 $item = $feed->get_item( $index );
This method returns item(s) in a $feed.
A valid zero-based array $index returns the corresponding item in the feed.
An invalid $index yields undef.
If $index is undefined in array context, it returns an array of all items.
If $index is undefined in scalar context, it returns the number of items.
=head2 @items = $feed->match_item( link => qr/.../, title => qr/.../, ... );
This method finds item(s) which match all regular expressions given.
This method returns an array of all matched items in array context.
This method returns the first matched item in scalar context.
=head2 $feed->remove_item( $index or $link );
This method removes an item/entry specified by zero-based array index or
link URL.
=head2 $feed->clear_item();
This method removes all items/entries from the $feed.
=head2 $feed->sort_item();
This method sorts the order of items in $feed by C<pubDate>.
=head2 $feed->uniq_item();
Reduces the list of items, not to include duplicates. RDF and Atoms
have a guid attribute to defined uniqueness, for RSS we use the link.
=head2 $feed->normalize();
This method calls both the C<sort_item()> and C<uniq_item()> methods.
=head2 $feed->limit_item( $num );
Removes items in excess of the specified numeric limit. Items at the
end of the list are removed. When preceded by C<sort_item()> or
C<normalize()>, this deletes more recent items.
=head2 $feed->xmlns( "xmlns:media" => "http://search.yahoo.com/mrss" );
Adds an XML namespace at the document root of the feed.
=head2 $url = $feed->xmlns( "xmlns:media" );
Returns the URL of the specified XML namespace.
=head2 @list = $feed->xmlns();
Returns the list of all XML namespaces used in $feed.
=head1 METHODS FOR CHANNEL
=head2 $feed->title( $text );
This method sets/gets the feed's C<title> element,
returning its current value when $title is undefined.
=head2 $feed->description( $html );
This method sets/gets the feed's C<description> element in plain text or HTML,
returning its current value when $html is undefined.
It is mapped to C<content> element for Atom 0.3/1.0.
=head2 $feed->pubDate( $date );
This method sets/gets the feed's C<pubDate> element for RSS,
returning its current value when $date is undefined.
It is mapped to C<dc:date> element for RDF,
C<modified> for Atom 0.3, and C<updated> for Atom 1.0.
See also L</DATE AND TIME FORMATS> section below.
=head2 $feed->copyright( $text );
This method sets/gets the feed's C<copyright> element for RSS,
returning its current value when $text is undefined.
It is mapped to C<dc:rights> element for RDF,
C<copyright> for Atom 0.3, and C<rights> for Atom 1.0.
=head2 $feed->link( $url );
This method sets/gets the URL of the web site as the feed's C<link> element,
returning its current value when the $url is undefined.
=head2 $feed->language( $lang );
This method sets/gets the feed's C<language> element for RSS,
returning its current value when the $lang is undefined.
It is mapped to C<dc:language> element for RDF,
C<feed xml:lang=""> for Atom 0.3/1.0.
=head2 $feed->image( $url, $title, $link, $description, $width, $height )
This method sets/gets the feed's C<image> element and its child nodes,
returning a list of current values when any arguments are undefined.
=head1 METHODS FOR ITEM
=head2 $item->title( $text );
This method sets/gets the item's C<title> element,
returning its current value when the $text is undefined.
=head2 $item->description( $html );
This method sets/gets the item's C<description> element in HTML or plain text,
returning its current value when $text is undefined.
It is mapped to C<content> element for Atom 0.3/1.0.
=head2 $item->pubDate( $date );
This method sets/gets the item's C<pubDate> element,
returning its current value when $date is undefined.
It is mapped to C<dc:date> element for RDF,
C<modified> for Atom 0.3, and C<updated> for Atom 1.0.
See also L</DATE AND TIME FORMATS> section below.
=head2 $item->category( $text );
This method sets/gets the item's C<category> element.
returning its current value when $text is undefined.
It is mapped to C<dc:subject> element for RDF, and ignored for Atom 0.3.
=head2 $item->author( $name );
This method sets/gets the item's C<author> element,
returning its current value when $name is undefined.
It is mapped to C<dc:creator> element for RDF,
C<author> for Atom 0.3/1.0.
=head2 $item->guid( $guid, isPermaLink => $bool );
This method sets/gets the item's C<guid> element,
returning its current value when $guid is undefined.
It is mapped to C<id> element for Atom, and ignored for RDF. In case of
RSS, it will return a HASH. The C<isParmaLink> is supported by RSS only,
and optional.
=head2 $item->set( $key => $value, ... );
This method sets customized node values or attributes.
See also L</ACCESSOR AND MUTATORS> section below.
=head2 $value = $item->get( $key );
This method returns the node value or attribute.
See also L</ACCESSOR AND MUTATORS> section below.
=head2 $link = $item->link();
This method returns the item's C<link> element.
=head1 ACCESSOR AND MUTATORS
This module understands only subset of C<rdf:*>, C<dc:*> modules
and RSS/RDF/Atom's default namespaces by itself.
There are NO native methods for any other external modules, such as C<media:*>.
But C<set()> and C<get()> methods are available to get/set
the value of any elements or attributes for these modules.
=head2 $item->set( "module:name" => $value );
This sets the value of the child node:
<item><module:name>$value</module:name>...</item>
=head2 $item->set( "module:name@attr" => $value );
This sets the value of the child node's attribute:
<item><module:name attr="$value" />...</item>
=head2 $item->set( "@attr" => $value );
This sets the value of the item's attribute:
<item attr="$value">...</item>
=head2 $item->set( "hoge/pomu@hare" => $value );
This code sets the value of the child node's child node's attribute:
<item><hoge><pomu attr="$value" /></hoge>...</item>
=head1 DATE AND TIME FORMATS
C<XML::FeedPP> allows you to describe date/time using any of the three
following formats:
=head2 $date = "Thu, 23 Feb 2006 14:43:43 +0900";
This is the HTTP protocol's preferred format and RSS 2.0's native
format, as defined by RFC 1123.
=head2 $date = "2006-02-23T14:43:43+09:00";
W3CDTF is the native format of RDF, as defined by ISO 8601.
=head2 $date = 1140705823;
The last format is the number of seconds since the epoch,
C<1970-01-01T00:00:00Z>.
You know, this is the native format of Perl's C<time()> function.
=head1 USING MEDIA RSS
To publish Media RSS, add the C<media> namespace then use C<set()>
setter method to manipulate C<media:content> element, etc.
my $feed = XML::FeedPP::RSS->new();
$feed->xmlns('xmlns:media' => 'http://search.yahoo.com/mrss/');
my $item = $feed->add_item('http://www.example.com/index.html');
$item->set('media:content@url' => 'http://www.example.com/image.jpg');
$item->set('media:content@type' => 'image/jpeg');
$item->set('media:content@width' => 640);
$item->set('media:content@height' => 480);
=head1 MODULE DEPENDENCIES
C<XML::FeedPP> requires only L<XML::TreePP>
which likewise is a pure Perl implementation.
The standard L<LWP::UserAgent> is required
to download feeds from remote web servers.
C<Jcode.pm> is required to convert Japanese encodings on Perl 5.005
and 5.6.1, but is NOT required on Perl 5.8.x and later.
=head1 AUTHOR
Yusuke Kawasaki, http://www.kawa.net/
=head1 COPYRIGHT
The following copyright notice applies to all the files provided in
this distribution, including binary files, unless explicitly noted
otherwise.
Copyright 2006-2011 Yusuke Kawasaki
=head1 LICENSE
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
# ----------------------------------------------------------------
package XML::FeedPP;
use strict;
use Carp;
use Time::Local;
use XML::TreePP;
use vars qw(
$VERSION $RSS20_VERSION $ATOM03_VERSION
$XMLNS_RDF $XMLNS_RSS $XMLNS_DC $XMLNS_ATOM03
$XMLNS_NOCOPY $TREEPP_OPTIONS $MIME_TYPES
$FEED_METHODS $ITEM_METHODS
$XMLNS_ATOM10
);
$VERSION = "0.95";
$RSS20_VERSION = '2.0';
$ATOM03_VERSION = '0.3';
$XMLNS_RDF = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#';
$XMLNS_RSS = 'http://purl.org/rss/1.0/';
$XMLNS_DC = 'http://purl.org/dc/elements/1.1/';
$XMLNS_ATOM03 = 'http://purl.org/atom/ns#';
$XMLNS_ATOM10 = 'http://www.w3.org/2005/Atom';
$XMLNS_NOCOPY = [qw( xmlns xmlns:rdf xmlns:dc xmlns:atom )];
$TREEPP_OPTIONS = {
force_array => [qw( item rdf:li entry )],
first_out => [qw( -xmlns:rdf -xmlns -rel -type url title link )],
last_out => [qw( description image item items entry -width -height )],
user_agent => "XML-FeedPP/$VERSION ",
};
$MIME_TYPES = { reverse qw(
image/bmp bmp
image/gif gif
image/jpeg jpeg
image/jpeg jpg
image/png png
image/svg+xml svg
image/x-icon ico
image/x-xbitmap xbm
image/x-xpixmap xpm
)};
$FEED_METHODS = [qw(
title
description
language
copyright
link
pubDate
image
set
)];
$ITEM_METHODS = [qw(
title
description
category
author
link
guid
pubDate
image
set
)];
sub new {
my $package = shift;
my( $init, $source, @rest ) = &XML::FeedPP::Util::param_even_odd(@_);
my $do_autodetect = $package eq __PACKAGE__;
Carp::croak "No feed source"
if $do_autodetect && !$source;
my $self = bless {}, $package;
$self->load($source, @rest) if $source;
if($do_autodetect) {
my $class = $self->detect_format;
unless ( $class ) {
my $root = ref $self ? join( " ", sort keys %$self ) : $self;
my $class = ref $self ? ref $self : $self;
Carp::croak "Invalid $class feed format: $root";
}
bless $self, $class;
}
$self->validate_feed() if $source;
$self->init_feed();
$self->elements(@$init) if ref $init;
$self;
}
sub validate_feed {
my $self = shift;
return if $self->test_feed(@_);
my $root = ref $self ? join( " ", sort keys %$self ) : $self;
my $class = ref $self ? ref $self : $self;
Carp::croak "Invalid $class feed format: $root";
}
sub detect_format {
my $self = shift;
my $list = $self->available_format;
foreach my $class ( @$list ) {
my $hit = $class->test_feed($self);
return $class if $hit;
}
undef;
}
sub available_format {
[ 'XML::FeedPP::RSS',
'XML::FeedPP::RDF',
'XML::FeedPP::Atom::Atom10',
'XML::FeedPP::Atom::Atom03',
'XML::FeedPP::Atom' ];
}
sub load {
my $self = shift;
my $source = shift;
my $args = { @_ };
my $method = $args->{'-type'};
Carp::croak "No feed source" unless defined $source;
if ( ! $method ) {
if ( $source =~ m#^https?://#s ) {
$method = 'url';
}
elsif ( $source =~ m#(?:\s*\xEF\xBB\xBF)?\s*
(<(\?xml|!DOCTYPE|rdf:RDF|rss|feed)\W)#xis ) {
$method = 'string';
}
elsif ( $source !~ /[\r\n]/ && -f $source ) {
$method = 'file';
}
else {
Carp::croak "Invalid feed source: $source";
}
}
my $opts = { map { $_ => $args->{$_} } grep { ! /^-/ } keys %$args };
my $tpp = XML::TreePP->new(%$TREEPP_OPTIONS, %$opts);
my $tree;
if ( $method eq 'url' ) {
$tree = $tpp->parsehttp( GET => $source );
}
elsif ( $method eq 'string' ) {
$tree = $tpp->parse($source);
}
elsif ( $method eq 'file' ) {
$tree = $tpp->parsefile($source);
}
else {
Carp::croak "Invalid load type: $method";
}
Carp::croak "Loading failed: $source" unless ref $tree;
%$self = %$tree; # override myself
$self;
}
sub to_string {
my $self = shift;
my( $args, $encode, @rest ) = XML::FeedPP::Util::param_even_odd(@_);
$args ||= \@rest;
my @opts = ( output_encoding => $encode ) if $encode;
my $tpp = XML::TreePP->new( %$TREEPP_OPTIONS, @opts, @$args );
$tpp->write( $self, $encode );
}
sub to_file {
my $self = shift;
my $file = shift;
my( $args, $encode, @rest ) = XML::FeedPP::Util::param_even_odd(@_);
$args ||= \@rest;
my @opts = ( output_encoding => $encode ) if $encode;
my $tpp = XML::TreePP->new( %$TREEPP_OPTIONS, @opts, @$args );
$tpp->writefile( $file, $self, $encode );
}
sub merge {
my $self = shift;
my $source = shift;
my $target = ref $source ? $source : XML::FeedPP->new($source, @_);
$self->merge_channel($target);
$self->merge_item($target);
$self->normalize();
$self;
}
sub merge_channel {
my $self = shift;
my $target = shift or return;
if ( ref $self eq ref $target ) {
$self->merge_native_channel($target);
}
else {
$self->merge_common_channel($target);
}
}
sub merge_item {
my $self = shift;
my $target = shift or return;
foreach my $item ( $target->get_item() ) {
$self->add_item( $item );
}
}
sub merge_common_channel {
my $self = shift;
my $target = shift or return;
my $title1 = $self->title();
my $title2 = $target->title();
$self->title($title2) if ( !defined $title1 && defined $title2 );
my $desc1 = $self->description();
my $desc2 = $target->description();
$self->description($desc2) if ( !defined $desc1 && defined $desc2 );
my $link1 = $self->link();
my $link2 = $target->link();
$self->link($link2) if ( !defined $link1 && defined $link2 );
my $lang1 = $self->language();
my $lang2 = $target->language();
$self->language($lang2) if ( !defined $lang1 && defined $lang2 );
my $right1 = $self->copyright();
my $right2 = $target->copyright();
$self->copyright($right2) if ( !defined $right1 && defined $right2 );
my $pubDate1 = $self->pubDate();
my $pubDate2 = $target->pubDate();
$self->pubDate($pubDate2) if ( !defined $pubDate1 && defined $pubDate2 );
my @image1 = $self->image();
my @image2 = $target->image();
$self->image(@image2) if ( !defined $image1[0] && defined $image2[0] );
my @xmlns1 = $self->xmlns();
my @xmlns2 = $target->xmlns();
my $xmlchk = { map { $_ => 1 } @xmlns1, @$XML::FeedPP::XMLNS_NOCOPY };
foreach my $ns (@xmlns2) {
next if exists $xmlchk->{$ns};
$self->xmlns( $ns, $target->xmlns($ns) );
}
$self->merge_module_nodes( $self->docroot, $target->docroot );
$self;
}
sub add_clone_item {
my $self = shift;
my $srcitem = shift or return;
my $link = $srcitem->link() or return;
my $dstitem = $self->add_item( $link );
if ( ref $dstitem eq ref $srcitem ) {
XML::FeedPP::Util::merge_hash( $dstitem, $srcitem );
# A new item starts with a link, and then a merge. Setting the
# link often affects the guid. The merge will not set the guid
# anymore. So, let's overrule that.
if(my $guid = $srcitem->{guid}) {
$dstitem->{guid} = $guid;
}
}
else {
my $title = $srcitem->title();
$dstitem->title($title) if defined $title;
my $description = $srcitem->description();
$dstitem->description($description) if defined $description;
my $category = $srcitem->category();
$dstitem->category($category) if defined $category;
my $author = $srcitem->author();
$dstitem->author($author) if defined $author;
my $guid = $srcitem->guid();
$dstitem->guid($guid) if defined $guid;
my $pubDate = $srcitem->pubDate();
$dstitem->pubDate($pubDate) if defined $pubDate;
$self->merge_module_nodes( $dstitem, $srcitem );
}
$dstitem;
}
sub merge_module_nodes {
my $self = shift;
my $item1 = shift;
my $item2 = shift;
foreach my $key ( grep { /:/ } keys %$item2 ) {
next if ( $key =~ /^-?(dc|rdf|xmlns):/ );
# deep copy would be better
$item1->{$key} = $item2->{$key};
}
}
sub normalize {
my $self = shift;
$self->normalize_pubDate();
$self->sort_item();
$self->uniq_item();
}
sub normalize_pubDate {
my $self = shift;
foreach my $item ( $self->get_item() ) {
my $date = $item->get_pubDate_native() or next;
$item->pubDate( $date );
}
my $date = $self->get_pubDate_native();
$self->pubDate( $date ) if $date;
}
sub xmlns {
my $self = shift;
my $ns = shift;
my $url = shift;
my $root = $self->docroot;
if ( !defined $ns ) {
my $list = [ grep { /^-xmlns(:\S|$)/ } keys %$root ];
return map { (/^-(.*)$/)[0] } @$list;
}
elsif ( !defined $url ) {
return unless exists $root->{ '-' . $ns };
return $root->{ '-' . $ns };
}
else {
$root->{ '-' . $ns } = $url;
}
}
sub get_pubDate_w3cdtf {
my $self = shift;
my $date = $self->get_pubDate_native();
XML::FeedPP::Util::get_w3cdtf($date);
}
sub get_pubDate_rfc1123 {
my $self = shift;
my $date = $self->get_pubDate_native();
XML::FeedPP::Util::get_rfc1123($date);
}
sub get_pubDate_epoch {
my $self = shift;
my $date = $self->get_pubDate_native();
XML::FeedPP::Util::get_epoch($date);
}
sub call {
my $self = shift;
my $name = shift;
my $class = __PACKAGE__."::Plugin::".$name;
my $pmfile = $class;
$pmfile =~ s#::#/#g;
$pmfile .= ".pm";
local $@;
eval {
require $pmfile;
} unless defined $class->VERSION;
Carp::croak "$class failed: $@" if $@;
return $class->run( $self, @_ );
}
sub elements {
my $self = shift;
my $args = [ @_ ];
my $methods = { map {$_=>1} @$FEED_METHODS };
while ( my $key = shift @$args ) {
my $val = shift @$args;
if ( $methods->{$key} ) {
$self->$key( $val );
} else {
$self->set( $key, $val );
}
}
}
sub match_item {
my $self = shift;
my @list = $self->get_item();
return unless scalar @list;
my $methods = { map {$_=>1} @$ITEM_METHODS };
my $args = [ @_ ];
my $out = [];
foreach my $item ( @list ) {
my $unmatch = 0;
my $i = 0;
while( 1 ) {
my $key = $args->[$i++] or last;
my $test = $args->[$i++];
my $got = $methods->{$key} ? $item->$key() : $item->get( $key );
unless ( $got =~ $test ) {
$unmatch ++;
last;
}
}
unless ( $unmatch ) {
return $item unless wantarray;
push( @$out, $item );
}
}
@$out;
}
sub channel_class { Carp::croak((ref $_[0])."->channel_class() is not implemented"); }
sub item_class { Carp::croak((ref $_[0])."->item_class() is not implemented"); }
sub test_feed { Carp::croak((ref $_[0])."->test_feed() is not implemented"); }
sub init_feed { Carp::croak((ref $_[0])."->init_feed() is not implemented"); }
sub add_item { Carp::croak((ref $_[0])."->add_item() is not implemented"); }
sub clear_item { Carp::croak((ref $_[0])."->clear_item() is not implemented"); }
sub remove_item { Carp::croak((ref $_[0])."->remove_item() is not implemented"); }
sub get_item { Carp::croak((ref $_[0])."->get_item() is not implemented"); }
sub sort_item { Carp::croak((ref $_[0])."->sort_item() is not implemented"); }
sub uniq_item { Carp::croak((ref $_[0])."->uniq_item() is not implemented"); }
sub limit_item { Carp::croak((ref $_[0])."->limit_item() is not implemented"); }
sub docroot { Carp::croak((ref $_[0])."->docroot() is not implemented"); }
sub channel { Carp::croak((ref $_[0])."->channel() is not implemented"); }
sub set { Carp::croak((ref $_[0])."->set() is not implemented"); }
sub get { Carp::croak((ref $_[0])."->get() is not implemented"); }
sub title { Carp::croak((ref $_[0])."->title() is not implemented"); }
sub description { Carp::croak((ref $_[0])."->description() is not implemented"); }
sub link { Carp::croak((ref $_[0])."->link() is not implemented"); }
sub language { Carp::croak((ref $_[0])."->language() is not implemented"); }
sub copyright { Carp::croak((ref $_[0])."->copyright() is not implemented"); }
sub pubDate { Carp::croak((ref $_[0])."->pubDate() is not implemented"); }
sub image { Carp::croak((ref $_[0])."->image() is not implemented"); }
# ----------------------------------------------------------------
package XML::FeedPP::Plugin;
use strict;
sub run {
my $class = shift;
my $feed = shift;
my $ref = ref $class ? ref $class : $class;
Carp::croak $ref."->run() is not implemented";
}
# ----------------------------------------------------------------
package XML::FeedPP::Item;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Element );
*get_pubDate_w3cdtf = \&XML::FeedPP::get_pubDate_w3cdtf; # import
*get_pubDate_rfc1123 = \&XML::FeedPP::get_pubDate_rfc1123;
*get_pubDate_epoch = \&XML::FeedPP::get_pubDate_epoch;
sub elements {
my $self = shift;
my $args = [ @_ ];
my $methods = { map {$_=>1} @$XML::FeedPP::ITEM_METHODS };
while ( my $key = shift @$args ) {
my $val = shift @$args;
if ( $methods->{$key} ) {
$self->$key( $val );
} else {
$self->set( $key, $val );
}
}
}
# ----------------------------------------------------------------
package XML::FeedPP::RSS;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP );
sub channel_class {
'XML::FeedPP::RSS::Channel';
}
sub item_class {
'XML::FeedPP::RSS::Item';
}
sub test_feed {
my $self = shift;
my $source = shift || $self;
return unless ref $source;
return unless ref $source->{rss};
__PACKAGE__;
}
sub init_feed {
my $self = shift or return;
$self->{rss} ||= {};
if ( ! UNIVERSAL::isa( $self->{rss}, 'HASH' ) ) {
Carp::croak "Invalid RSS 2.0 feed format: $self->{rss}";
}
$self->{rss}->{'-version'} ||= $XML::FeedPP::RSS20_VERSION;
my $channel = $self->{rss}{channel} ||= $self->channel_class->new();
$self->channel_class->ref_bless($channel);
my $items = $channel->{item} || [];
my @items = grep ref $_, # skip empty items
UNIVERSAL::isa($items, 'HASH') ? $items : @$items;
$self->item_class->ref_bless($_) for @items;
$channel->{item} = \@items;
$self;
}
sub merge_native_channel {
my $self = shift;
my $tree = shift or next;
XML::FeedPP::Util::merge_hash( $self->{rss}, $tree->{rss}, qw( channel ) );
XML::FeedPP::Util::merge_hash(
$self->{rss}->{channel},
$tree->{rss}->{channel},
qw( item )
);
}
sub add_item {
my $self = shift;
my( $init, $link, @rest ) = &XML::FeedPP::Util::param_even_odd(@_);
Carp::croak "add_item needs an argument" if ( ! ref $init && ! $link );
if ( ref $link ) {
return $self->add_clone_item( $link );
}
my $item = XML::FeedPP::RSS::Item->new(@rest);
$item->link($link) if $link;
$item->elements(@$init) if ref $init;
push( @{ $self->{rss}->{channel}->{item} }, $item );
$item;
}
sub clear_item {
my $self = shift;
$self->{rss}->{channel}->{item} = [];
}
sub remove_item {
my $self = shift;
my $remove = shift;
my $list = $self->{rss}->{channel}->{item} or return;
my @deleted;
if ( $remove =~ /^-?\d+/ ) {
@deleted = splice( @$list, $remove, 1 );
}
else {
@deleted = grep { $_->link() eq $remove } @$list;
@$list = grep { $_->link() ne $remove } @$list;
}
wantarray ? @deleted : shift @deleted;
}
sub get_item {
my $self = shift;
my $num = shift;
$self->{rss}->{channel}->{item} ||= [];
if ( defined $num ) {
return $self->{rss}->{channel}->{item}->[$num];
}
elsif (wantarray) {
return @{ $self->{rss}->{channel}->{item} };
}
else {
return scalar @{ $self->{rss}->{channel}->{item} };
}
}
sub sort_item {
my $self = shift;
my $list = $self->{rss}->{channel}->{item} or return;
my $epoch = [ map { $_->get_pubDate_epoch() || 0 } @$list ];
my $sorted = [ map { $list->[$_] } sort {
$epoch->[$b] <=> $epoch->[$a]
} 0 .. $#$list ];
@$list = @$sorted;
scalar @$list;
}
sub uniq_item {
my $self = shift;
my $list = $self->{rss}->{channel}->{item} or return;
my (%check, @uniq);
foreach my $item (@$list) {
my $key = $item->guid() || $item->link();
push( @uniq, $item ) unless $check{$key}++;
}
@$list = @uniq;
scalar @$list;
}
sub limit_item {
my $self = shift;
my $limit = shift;
my $list = $self->{rss}->{channel}->{item} or return;
if ( $limit > 0 && $limit < scalar @$list ) {
@$list = splice( @$list, 0, $limit ); # remove from end
}
elsif ( $limit < 0 && -$limit < scalar @$list ) {
@$list = splice( @$list, $limit ); # remove from start
}
scalar @$list;
}
sub docroot { shift->{rss}; }
sub channel { shift->{rss}->{channel}; }
sub set { shift->{rss}->{channel}->set(@_); }
sub get { shift->{rss}->{channel}->get(@_); }
sub title { shift->{rss}->{channel}->get_or_set( "title", @_ ); }
sub description { shift->{rss}->{channel}->get_or_set( "description", @_ ); }
sub link { shift->{rss}->{channel}->get_or_set( "link", @_ ); }
sub language { shift->{rss}->{channel}->get_or_set( "language", @_ ); }
sub copyright { shift->{rss}->{channel}->get_or_set( "copyright", @_ ); }
sub pubDate {
my $self = shift;
my $date = shift;
return $self->get_pubDate_w3cdtf() unless defined $date;
$date = XML::FeedPP::Util::get_rfc1123($date);
$self->{rss}->{channel}->set_value( "pubDate", $date );
}
sub get_pubDate_native {
my $self = shift;
$self->{rss}->{channel}->get_value("pubDate") # normal RSS 2.0
|| $self->{rss}->{channel}->get_value("dc:date"); # strange
}
sub image {
my $self = shift;
my $url = shift;
if ( defined $url ) {
my ( $title, $link, $desc, $width, $height ) = @_;
$self->{rss}->{channel}->{image} ||= {};
my $image = $self->{rss}->{channel}->{image};
$image->{url} = $url;
$image->{title} = $title if defined $title;
$image->{link} = $link if defined $link;
$image->{description} = $desc if defined $desc;
$image->{width} = $width if defined $width;
$image->{height} = $height if defined $height;
}
elsif ( exists $self->{rss}->{channel}->{image} ) {
my $image = $self->{rss}->{channel}->{image};
my $array = [];
foreach my $key (qw( url title link description width height )) {
push( @$array, exists $image->{$key} ? $image->{$key} : undef );
}
return wantarray ? @$array : shift @$array;
}
undef;
}
# ----------------------------------------------------------------
package XML::FeedPP::RSS::Channel;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Element );
# ----------------------------------------------------------------
package XML::FeedPP::RSS::Item;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Item );
sub title { shift->get_or_set( "title", @_ ); }
sub description { shift->get_or_set( "description", @_ ); }
sub category { shift->get_set_array( "category", @_ ); }
sub author {
my $self = shift;
if ( scalar @_ ) {
$self->set_value( 'author', @_ );
} else {
$self->get_value('author') || $self->get_value('dc:creator');
}
}
sub link {
my $self = shift;
my $link = shift;
return $self->get_value("link") unless defined $link;
$self->guid($link) unless defined $self->guid();
$self->set_value( link => $link );
}
sub guid {
my $self = shift;
my $guid = shift;
return $self->get_value("guid") unless defined $guid;
my @args = @_;
if ( ! scalar @args ) {
# default
@args = ( 'isPermaLink' => 'true' );
} elsif ( scalar @args == 1 ) {
# XML::FeedPP 0.36's behavior
unshift( @args, 'isPermaLink' );
}
$self->set_value( guid => $guid, @args );
}
sub pubDate {
my $self = shift;
my $date = shift;
return $self->get_pubDate_w3cdtf() unless defined $date;
$date = XML::FeedPP::Util::get_rfc1123($date);
$self->set_value( "pubDate", $date );
}
sub get_pubDate_native {
my $self = shift;
$self->get_value("pubDate") # normal RSS 2.0
|| $self->get_value("dc:date"); # strange
}
sub image {
my $self = shift;
my $url = shift;
if ( defined $url ) {
my ( $title, $link, $desc, $width, $height ) = @_;
$self->{image} ||= {};
my $image = $self->{image};
$image->{url} = $url;
$image->{title} = $title if defined $title;
$image->{link} = $link if defined $link;
$image->{description} = $desc if defined $desc;
$image->{width} = $width if defined $width;
$image->{height} = $height if defined $height;
}
elsif ( exists $self->{image} ) {
my $image = $self->{image};
my $array = [];
foreach my $key (qw( url title link description width height )) {
push( @$array, exists $image->{$key} ? $image->{$key} : undef );
}
return wantarray ? @$array : shift @$array;
}
undef;
}
# ----------------------------------------------------------------
package XML::FeedPP::RDF;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP );
sub channel_class {
'XML::FeedPP::RDF::Channel';
}
sub item_class {
'XML::FeedPP::RDF::Item';
}
sub test_feed {
my $self = shift;
my $source = shift || $self;
return unless ref $source;
return unless ref $source->{'rdf:RDF'};
__PACKAGE__;
}
sub init_feed {
my $self = shift or return;
$self->{'rdf:RDF'} ||= {};
if ( ! UNIVERSAL::isa( $self->{'rdf:RDF'}, 'HASH' ) ) {
Carp::croak "Invalid RDF 1.0 feed format: $self->{'rdf:RDF'}";
}
$self->xmlns( 'xmlns' => $XML::FeedPP::XMLNS_RSS );
$self->xmlns( 'xmlns:rdf' => $XML::FeedPP::XMLNS_RDF );
$self->xmlns( 'xmlns:dc' => $XML::FeedPP::XMLNS_DC );
$self->{'rdf:RDF'}->{channel} ||= $self->channel_class->new();
$self->channel_class->ref_bless( $self->{'rdf:RDF'}->{channel} );
$self->{'rdf:RDF'}->{channel}->{items} ||= {};
$self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'} ||= {};
my $rdfseq = $self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'};
# http://www.kawa.net/works/perl/feedpp/feedpp.html#com-2008-05-17T13:13:33Z
if ( UNIVERSAL::isa( $rdfseq, 'ARRAY' ) ) {
my $num1 = scalar @$rdfseq;
my $num2 = scalar grep { ref $_ && exists $_->{'rdf:li'} && ref $_->{'rdf:li'} } @$rdfseq;
my $num3 = scalar grep { ref $_ && keys %$_ == 1 } @$rdfseq;
if ( $num1 && $num1 == $num2 && $num1 == $num3 ) {
my $newli = [ map { @{$_->{'rdf:li'}} } @$rdfseq ];
$rdfseq = { 'rdf:li' => $newli };
$self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'} = $rdfseq;
}
}
$rdfseq->{'rdf:li'} ||= [];
if ( UNIVERSAL::isa( $rdfseq->{'rdf:li'}, 'HASH' ) ) {
$rdfseq->{'rdf:li'} = [ $rdfseq->{'rdf:li'} ];
}
$self->{'rdf:RDF'}->{item} ||= [];
if ( UNIVERSAL::isa( $self->{'rdf:RDF'}->{item}, 'HASH' ) ) {
# force array when only one item exist
$self->{'rdf:RDF'}->{item} = [ $self->{'rdf:RDF'}->{item} ];
}
foreach my $item ( @{ $self->{'rdf:RDF'}->{item} } ) {
$self->item_class->ref_bless($item);
}
$self;
}
sub merge_native_channel {
my $self = shift;
my $tree = shift or next;
XML::FeedPP::Util::merge_hash( $self->{'rdf:RDF'}, $tree->{'rdf:RDF'},
qw( channel item ) );
XML::FeedPP::Util::merge_hash(
$self->{'rdf:RDF'}->{channel},
$tree->{'rdf:RDF'}->{channel},
qw( items )
);
}
sub add_item {
my $self = shift;
my( $init, $link, @rest ) = &XML::FeedPP::Util::param_even_odd(@_);
Carp::croak "add_item needs an argument" if ( ! ref $init && ! $link );
if ( ref $link ) {
return $self->add_clone_item( $link );
}
my $rdfli = $self->item_class->new();
$rdfli->{'-rdf:resource'} = $link;
$self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'}->{'rdf:li'} ||= [];
push(
@{ $self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'}->{'rdf:li'} },
$rdfli
);
my $item = XML::FeedPP::RDF::Item->new(@rest);
$item->link($link) if $link;
$item->elements(@$init) if ref $init;
push( @{ $self->{'rdf:RDF'}->{item} }, $item );
$item;
}
sub clear_item {
my $self = shift;
$self->{'rdf:RDF'}->{item} = [];
$self->__refresh_items();
}
sub remove_item {
my $self = shift;
my $remove = shift;
my $list = $self->{'rdf:RDF'}->{item} or return;
my @deleted;
if ( $remove =~ /^-?\d+/ ) {
@deleted = splice( @$list, $remove, 1 );
}
else {
@deleted = grep { $_->link() eq $remove } @$list;
@$list = grep { $_->link() ne $remove } @$list;
}
$self->__refresh_items();
wantarray ? @deleted : shift @deleted;
}
sub get_item {
my $self = shift;
my $num = shift;
$self->{'rdf:RDF'}->{item} ||= [];
if ( defined $num ) {
return $self->{'rdf:RDF'}->{item}->[$num];
}
elsif (wantarray) {
return @{ $self->{'rdf:RDF'}->{item} };
}
else {
return scalar @{ $self->{'rdf:RDF'}->{item} };
}
}
sub sort_item {
my $self = shift;
my $list = $self->{'rdf:RDF'}->{item} or return;
my $epoch = [ map { $_->get_pubDate_epoch() || 0 } @$list ];
my $sorted = [ map { $list->[$_] } sort {
$epoch->[$b] <=> $epoch->[$a]
} 0 .. $#$list ];
@$list = @$sorted;
$self->__refresh_items();
}
sub uniq_item {
my $self = shift;
my $list = $self->{'rdf:RDF'}->{item} or return;
my (%check, @uniq);
foreach my $item (@$list) {
my $link = $item->link();
push( @uniq, $item ) unless $check{$link}++;
}
$self->{'rdf:RDF'}->{item} = \@uniq;
$self->__refresh_items();
}
sub limit_item {
my $self = shift;
my $limit = shift;
my $list = $self->{'rdf:RDF'}->{item} or return;
if ( $limit > 0 && $limit < scalar @$list ) {
@$list = splice( @$list, 0, $limit ); # remove from end
}
elsif ( $limit < 0 && -$limit < scalar @$list ) {
@$list = splice( @$list, $limit ); # remove from start
}
$self->__refresh_items();
}
sub __refresh_items {
my $self = shift;
my $list = $self->{'rdf:RDF'}->{item} or return;
$self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'}->{'rdf:li'} = [];
my $dest = $self->{'rdf:RDF'}->{channel}->{items}->{'rdf:Seq'}->{'rdf:li'};
foreach my $item (@$list) {
my $rdfli = XML::FeedPP::Element->new();
$rdfli->{'-rdf:resource'} = $item->link();
push( @$dest, $rdfli );
}
scalar @$dest;
}
sub docroot { shift->{'rdf:RDF'}; }
sub channel { shift->{'rdf:RDF'}->{channel}; }
sub set { shift->{'rdf:RDF'}->{channel}->set(@_); }
sub get { shift->{'rdf:RDF'}->{channel}->get(@_); }
sub title { shift->{'rdf:RDF'}->{channel}->get_or_set( "title", @_ ); }
sub description { shift->{'rdf:RDF'}->{channel}->get_or_set( "description", @_ ); }
sub language { shift->{'rdf:RDF'}->{channel}->get_or_set( "dc:language", @_ ); }
sub copyright { shift->{'rdf:RDF'}->{channel}->get_or_set( "dc:rights", @_ ); }
sub link {
my $self = shift;
my $link = shift;
return $self->{'rdf:RDF'}->{channel}->get_value("link")
unless defined $link;
$self->{'rdf:RDF'}->{channel}->{'-rdf:about'} = $link;
$self->{'rdf:RDF'}->{channel}->set_value( "link", $link, @_ );
}
sub pubDate {
my $self = shift;
my $date = shift;
return $self->get_pubDate_w3cdtf() unless defined $date;
$date = XML::FeedPP::Util::get_w3cdtf($date);
$self->{'rdf:RDF'}->{channel}->set_value( "dc:date", $date );
}
sub get_pubDate_native {
shift->{'rdf:RDF'}->{channel}->get_value("dc:date");
}
*get_pubDate_w3cdtf = \&get_pubDate_native;
sub image {
my $self = shift;
my $url = shift;
if ( defined $url ) {
my ( $title, $link ) = @_;
$self->{'rdf:RDF'}->{channel}->{image} ||= {};
$self->{'rdf:RDF'}->{channel}->{image}->{'-rdf:resource'} = $url;
$self->{'rdf:RDF'}->{image} ||= {};
$self->{'rdf:RDF'}->{image}->{'-rdf:about'} = $url; # fix
my $image = $self->{'rdf:RDF'}->{image};
$image->{url} = $url;
$image->{title} = $title if defined $title;
$image->{link} = $link if defined $link;
}
elsif ( exists $self->{'rdf:RDF'}->{image} ) {
my $image = $self->{'rdf:RDF'}->{image};
my $array = [];
foreach my $key (qw( url title link )) {
push( @$array, exists $image->{$key} ? $image->{$key} : undef );
}
return wantarray ? @$array : shift @$array;
}
elsif ( exists $self->{'rdf:RDF'}->{channel}->{image} ) {
return $self->{'rdf:RDF'}->{channel}->{image}->{'-rdf:resource'};
}
undef;
}
# ----------------------------------------------------------------
package XML::FeedPP::RDF::Channel;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Element );
# ----------------------------------------------------------------
package XML::FeedPP::RDF::Item;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Item );
sub title { shift->get_or_set( "title", @_ ); }
sub description { shift->get_or_set( "description", @_ ); }
sub category { shift->get_set_array( "dc:subject", @_ ); }
sub guid { undef; } # this element is NOT supported for RDF
sub author {
my $self = shift;
my $author = shift;
return $self->get_value('dc:creator')
|| $self->get_value('creator') unless defined $author;
$self->set_value( 'dc:creator' => $author );
}
sub link {
my $self = shift;
my $link = shift;
return $self->get_value("link") unless defined $link;
$self->{'-rdf:about'} = $link;
$self->set_value( "link", $link, @_ );
}
sub pubDate {
my $self = shift;
my $date = shift;
return $self->get_pubDate_w3cdtf() unless defined $date;
$date = XML::FeedPP::Util::get_w3cdtf($date);
$self->set_value( "dc:date", $date );
}
sub get_pubDate_native {
shift->get_value("dc:date");
}
*get_pubDate_w3cdtf = \&get_pubDate_native;
# ----------------------------------------------------------------
package XML::FeedPP::Atom::Common;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP );
sub merge_native_channel {
my $self = shift;
my $tree = shift or next;
XML::FeedPP::Util::merge_hash( $self->{feed}, $tree->{feed}, qw( entry ) );
}
sub add_item {
my $self = shift;
my( $init, $link, @rest ) = &XML::FeedPP::Util::param_even_odd(@_);
Carp::croak "add_item needs an argument" if ( ! ref $init && ! $link );
if ( ref $link ) {
return $self->add_clone_item( $link );
}
my $item = $self->item_class->new(@rest);
$item->link($link) if $link;
$item->elements(@$init) if ref $init;
push( @{ $self->{feed}->{entry} }, $item );
$item;
}
sub clear_item {
my $self = shift;
$self->{feed}->{entry} = [];
}
sub remove_item {
my $self = shift;
my $remove = shift;
my $list = $self->{feed}->{entry} or return;
my @deleted;
if ( $remove =~ /^-?\d+/ ) {
@deleted = splice( @$list, $remove, 1 );
}
else {
@deleted = grep { $_->link() eq $remove } @$list;
@$list = grep { $_->link() ne $remove } @$list;
}
wantarray ? @deleted : shift @deleted;
}
sub get_item {
my $self = shift;
my $num = shift;
$self->{feed}->{entry} ||= [];
if ( defined $num ) {
return $self->{feed}->{entry}->[$num];
}
elsif (wantarray) {
return @{ $self->{feed}->{entry} };
}
else {
return scalar @{ $self->{feed}->{entry} };
}
}
sub sort_item {
my $self = shift;
my $list = $self->{feed}->{entry} or return;
my $epoch = [ map { $_->get_pubDate_epoch() || 0 } @$list ];
my $sorted = [ map { $list->[$_] } sort {
$epoch->[$b] <=> $epoch->[$a]
} 0 .. $#$list ];
@$list = @$sorted;
scalar @$list;
}
sub uniq_item {
my $self = shift;
my $list = $self->{feed}->{entry} or return;
my (%check, @uniq);
foreach my $item (@$list) {
my $link = $item->guid();
push( @uniq, $item ) unless $check{$link}++;
}
@$list = @uniq;
}
sub limit_item {
my $self = shift;
my $limit = shift;
my $list = $self->{feed}->{entry} or return;
if ( $limit > 0 && $limit < scalar @$list ) {
@$list = splice( @$list, 0, $limit ); # remove from end
}
elsif ( $limit < 0 && -$limit < scalar @$list ) {
@$list = splice( @$list, $limit ); # remove from start
}
scalar @$list;
}
sub docroot { shift->{feed}; }
sub channel { shift->{feed}; }
sub set { shift->{feed}->set(@_); }
sub get { shift->{feed}->get(@_); }
sub language {
my $self = shift;
my $lang = shift;
return $self->{feed}->{'-xml:lang'} unless defined $lang;
$self->{feed}->{'-xml:lang'} = $lang;
}
sub image {
my $self = shift;
my $href = shift;
my $title = shift;
my $link = $self->{feed}->{link} || [];
$link = [$link] if UNIVERSAL::isa( $link, 'HASH' );
my $icon = (
grep {
ref $_
&& exists $_->{'-rel'}
&& ($_->{'-rel'} eq "icon" )
} @$link
)[0];
my $rext = join( "|", map {"\Q$_\E"} keys %$XML::FeedPP::MIME_TYPES );
if ( defined $href ) {
my $ext = ( $href =~ m#[^/]\.($rext)(\W|$)#i )[0];
my $type = $XML::FeedPP::MIME_TYPES->{$ext} if $ext;
if ( ref $icon ) {
$icon->{'-href'} = $href;
$icon->{'-type'} = $type if $type;
$icon->{'-title'} = $title if $title;
}
else {
my $newicon = {};
$newicon->{'-rel'} = 'icon';
$newicon->{'-href'} = $href;
$newicon->{'-type'} = $type if $type;
$newicon->{'-title'} = $title if $title;
my $flink = $self->{feed}->{link};
if ( UNIVERSAL::isa( $flink, 'ARRAY' )) {
push( @$flink, $newicon );
}
elsif ( UNIVERSAL::isa( $flink, 'HASH' )) {
$self->{feed}->{link} = [ $flink, $newicon ];
}
else {
$self->{feed}->{link} = [ $newicon ];
}
}
}
elsif ( ref $icon ) {
my $array = [ $icon->{'-href'} ];
push( @$array, $icon->{'-title'} ) if exists $icon->{'-title'};
return wantarray ? @$array : shift @$array;
}
undef;
}
# ----------------------------------------------------------------
package XML::FeedPP::Atom::Atom03;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Atom::Common );
sub channel_class {
'XML::FeedPP::Atom::Atom03::Feed';
}
sub item_class {
'XML::FeedPP::Atom::Atom03::Entry';
}
sub test_feed {
my $self = shift;
my $source = shift || $self;
return unless ref $source;
return unless ref $source->{feed};
return unless exists $source->{feed}->{-xmlns};
my $xmlns = $source->{feed}->{-xmlns};
return if ($xmlns ne $XML::FeedPP::XMLNS_ATOM03);
__PACKAGE__;
}
sub init_feed {
my $self = shift or return;
$self->{feed} ||= $self->channel_class->new();
$self->channel_class->ref_bless( $self->{feed} );
if ( ! UNIVERSAL::isa( $self->{feed}, 'HASH' ) ) {
Carp::croak "Invalid Atom 0.3 feed format: $self->{feed}";
}
$self->xmlns( 'xmlns' => $XML::FeedPP::XMLNS_ATOM03 );
$self->{feed}->{'-version'} ||= $XML::FeedPP::ATOM03_VERSION;
$self->{feed}->{entry} ||= [];
if ( UNIVERSAL::isa( $self->{feed}->{entry}, 'HASH' ) ) {
# if this feed has only one item
$self->{feed}->{entry} = [ $self->{feed}->{entry} ];
}
foreach my $item ( @{ $self->{feed}->{entry} } ) {
$self->item_class->ref_bless($item);
}
$self->{feed}->{author} ||= { name => '' }; # dummy for validation
$self;
}
sub title {
my $self = shift;
my $title = shift;
return $self->{feed}->get_value('title') unless defined $title;
$self->{feed}->set_value( 'title' => $title, type => 'text/plain' );
}
sub description {
my $self = shift;
my $desc = shift;
return $self->{feed}->get_value('tagline')
|| $self->{feed}->get_value('subtitle') unless defined $desc;
$self->{feed}->set_value( 'tagline' => $desc, type => 'text/html', mode => 'escaped' );
}
sub pubDate {
my $self = shift;
my $date = shift;
return $self->get_pubDate_w3cdtf() unless defined $date;
$date = XML::FeedPP::Util::get_w3cdtf($date);
$self->{feed}->set_value( 'modified', $date );
}
sub get_pubDate_native {
my $self = shift;
$self->{feed}->get_value('modified') # Atom 0.3
|| $self->{feed}->get_value('updated'); # Atom 1.0
}
*get_pubDate_w3cdtf = \&get_pubDate_native;
sub copyright {
my $self = shift;
my $copy = shift;
return $self->{feed}->get_value('copyright')
|| $self->{feed}->get_value('rights') unless defined $copy;
$self->{feed}->set_value( 'copyright' => $copy );
}
sub link {
my $self = shift;
my $href = shift;
my $link = $self->{feed}->{link} || [];
$link = [$link] if UNIVERSAL::isa( $link, 'HASH' );
$link = [ grep { ref $_ } @$link ];
$link = [ grep {
! exists $_->{'-rel'} || $_->{'-rel'} eq 'alternate'
} @$link ];
$link = [ grep {
! exists $_->{'-type'} || $_->{'-type'} =~ m#^text/(x-)?html#i
} @$link ];
my $html = shift @$link;
if ( defined $href ) {
if ( ref $html ) {
$html->{'-href'} = $href;
}
else {
my $hash = {
-rel => 'alternate',
-type => 'text/html',
-href => $href,
};
my $flink = $self->{feed}->{link};
if ( ! ref $flink ) {
$self->{feed}->{link} = [ $hash ];
}
elsif ( UNIVERSAL::isa( $flink, 'ARRAY' )) {
push( @$flink, $hash );
}
elsif ( UNIVERSAL::isa( $flink, 'HASH' )) {
$self->{feed}->{link} = [ $flink, $hash ];
}
}
}
elsif ( ref $html ) {
return $html->{'-href'};
}
return;
}
# ----------------------------------------------------------------
package XML::FeedPP::Atom::Atom10;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Atom::Common );
sub channel_class {
'XML::FeedPP::Atom::Atom10::Feed';
}
sub item_class {
'XML::FeedPP::Atom::Atom10::Entry';
}
sub test_feed {
my $self = shift;
my $source = shift || $self;
return unless ref $source;
return unless ref $source->{feed};
return unless exists $source->{feed}->{-xmlns};
my $xmlns = $source->{feed}->{-xmlns};
return if ($xmlns ne $XML::FeedPP::XMLNS_ATOM10);
__PACKAGE__;
}
sub init_feed {
my $self = shift or return;
$self->{feed} ||= $self->channel_class->new();
$self->channel_class->ref_bless( $self->{feed} );
if ( ! UNIVERSAL::isa( $self->{feed}, 'HASH' ) ) {
Carp::croak "Invalid Atom 1.0 feed format: $self->{feed}";
}
$self->xmlns( 'xmlns' => $XML::FeedPP::XMLNS_ATOM10 );
# $self->{feed}->{'-version'} ||= $XML::FeedPP::ATOM10_VERSION;
$self->{feed}->{entry} ||= [];
if ( UNIVERSAL::isa( $self->{feed}->{entry}, 'HASH' ) ) {
# if this feed has only one item
$self->{feed}->{entry} = [ $self->{feed}->{entry} ];
}
foreach my $item ( @{ $self->{feed}->{entry} } ) {
$self->item_class->ref_bless($item);
}
# $self->{feed}->{author} ||= { name => '' }; # dummy for validation
$self;
}
sub title {
my $self = shift;
my $title = shift;
return $self->{feed}->get_value('title') unless defined $title;
$self->{feed}->set_value( 'title' => $title, @_ );
}
sub description {
my $self = shift;
my $desc = shift;
return $self->{feed}->get_value('content')
|| $self->{feed}->get_value('summary')
|| $self->{feed}->get_value('subtitle')
|| $self->{feed}->get_value('tagline') unless defined $desc;
$self->{feed}->set_value( 'content' => $desc, @_ ); # type => 'text'
}
sub pubDate {
my $self = shift;
my $date = shift;
return $self->get_pubDate_w3cdtf() unless defined $date;
$date = XML::FeedPP::Util::get_w3cdtf($date);
$self->{feed}->set_value( 'updated', $date );
}
sub get_pubDate_native {
my $self = shift;
$self->{feed}->get_value('updated') # Atom 1.0
|| $self->{feed}->get_value('modified') # Atom 0.3
}
*get_pubDate_w3cdtf = \&get_pubDate_native;
sub copyright {
my $self = shift;
my $copy = shift;
return $self->{feed}->get_value('rights')
|| $self->{feed}->get_value('copyright') unless defined $copy;
$self->{feed}->set_value( 'rights' => $copy );
}
sub link {
my $self = shift;
my $href = shift;
my $link = $self->{feed}->{link} || [];
$link = [$link] if UNIVERSAL::isa( $link, 'HASH' );
$link = [ grep { ref $_ } @$link ];
$link = [ grep {
! exists $_->{'-rel'} || $_->{'-rel'} eq 'alternate'
} @$link ];
my $html = shift @$link;
if ( defined $href ) {
if ( ref $html ) {
$html->{'-href'} = $href;
}
else {
my $hash = {
-rel => 'alternate',
-href => $href,
};
my $flink = $self->{feed}->{link};
if ( ! ref $flink ) {
$self->{feed}->{link} = [ $hash ];
}
elsif ( UNIVERSAL::isa( $flink, 'ARRAY' )) {
push( @$flink, $hash );
}
elsif ( UNIVERSAL::isa( $flink, 'HASH' )) {
$self->{feed}->{link} = [ $flink, $hash ];
}
}
}
elsif ( ref $html ) {
return $html->{'-href'};
}
return;
}
# ----------------------------------------------------------------
package XML::FeedPP::Atom;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Atom::Atom03 );
# @ISA = qw( XML::FeedPP::Atom::Atom10 ); # if Atom 1.0 for default
sub test_feed {
my $self = shift;
my $source = shift || $self;
return unless ref $source;
return unless ref $source->{feed};
__PACKAGE__;
}
# ----------------------------------------------------------------
package XML::FeedPP::Atom::Common::Feed;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Element );
# <content type="xhtml"><div>...</div></content>
# http://www.ietf.org/rfc/rfc4287.txt
# 3. If the value of "type" is "xhtml", the content of atom:content
# MUST be a single XHTML div element [XHTML] and SHOULD be suitable
# for handling as XHTML. The XHTML div element itself MUST NOT be
# considered part of the content.
sub _fetch_value {
my $self = shift;
my $value = shift;
if ( UNIVERSAL::isa( $value, 'HASH' )
&& exists $value->{'-type'}
&& ($value->{'-type'} eq "xhtml")) {
my $child = [ grep { /^[^\-\#]/ } keys %$value ];
if (scalar @$child == 1) {
my $div = shift @$child;
if ($div =~ /^([^:]+:)?div$/i) {
return $value->{$div};
}
}
}
$self->SUPER::_fetch_value($value);
}
# ----------------------------------------------------------------
package XML::FeedPP::Atom::Atom03::Feed;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Atom::Common::Feed );
# ----------------------------------------------------------------
package XML::FeedPP::Atom::Atom10::Feed;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Atom::Common::Feed );
# ----------------------------------------------------------------
package XML::FeedPP::Atom::Common::Entry;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Item );
sub author {
my $self = shift;
my $name = shift;
unless ( defined $name ) {
my $author = $self->{author}->{name} if ref $self->{author};
return $author;
}
my $author = ref $name ? $name : { name => $name };
$self->{author} = $author;
}
sub guid { shift->get_or_set( 'id', @_ ); }
*_fetch_value = \&XML::FeedPP::Atom::Common::Feed::_fetch_value;
# ----------------------------------------------------------------
package XML::FeedPP::Atom::Atom03::Entry;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Atom::Common::Entry );
sub description {
my $self = shift;
my $desc = shift;
return $self->get_value('content')
|| $self->get_value('summary') unless defined $desc;
$self->set_value(
'content' => $desc,
type => 'text/html',
mode => 'escaped'
);
}
sub link {
my $self = shift;
my $href = shift;
my $link = $self->{link} || [];
$link = [$link] if UNIVERSAL::isa( $link, 'HASH' );
$link = [ grep { ref $_ } @$link ];
$link = [ grep {
! exists $_->{'-rel'} || $_->{'-rel'} eq 'alternate'
} @$link ];
$link = [ grep {
! exists $_->{'-type'} || $_->{'-type'} =~ m#^text/(x-)?html#i
} @$link ];
my $html = shift @$link;
if ( defined $href ) {
if ( ref $html ) {
$html->{'-href'} = $href;
}
else {
my $hash = {
-rel => 'alternate',
-type => 'text/html',
-href => $href,
};
my $flink = $self->{link};
if ( ! ref $flink ) {
$self->{link} = [ $hash ];
}
elsif ( ref $flink && UNIVERSAL::isa( $flink, 'ARRAY' )) {
push( @$flink, $hash );
}
elsif ( ref $flink && UNIVERSAL::isa( $flink, 'HASH' )) {
$self->{link} = [ $flink, $hash ];
}
}
$self->guid( $href ) unless defined $self->guid();
}
elsif ( ref $html ) {
return $html->{'-href'};
}
return;
}
sub pubDate {
my $self = shift;
my $date = shift;
return $self->get_pubDate_w3cdtf() unless defined $date;
$date = XML::FeedPP::Util::get_w3cdtf($date);
$self->set_value( 'issued', $date );
$self->set_value( 'modified', $date );
}
sub get_pubDate_native {
my $self = shift;
$self->get_value('modified') # Atom 0.3
|| $self->get_value('issued') # Atom 0.3
|| $self->get_value('updated') # Atom 1.0
|| $self->get_value('published'); # Atom 1.0
}
*get_pubDate_w3cdtf = \&get_pubDate_native;
sub title {
my $self = shift;
my $title = shift;
return $self->get_value('title') unless defined $title;
$self->set_value( 'title' => $title, type => 'text/plain' );
}
sub category { undef; } # this element is NOT supported for Atom 0.3
# ----------------------------------------------------------------
package XML::FeedPP::Atom::Atom10::Entry;
use strict;
use vars qw( @ISA );
@ISA = qw( XML::FeedPP::Atom::Common::Entry );
sub description {
my $self = shift;
my $desc = shift;
return $self->get_value('content')
|| $self->get_value('summary') unless defined $desc;
$self->set_value( 'content' => $desc, @_ );
}
sub link {
my $self = shift;
my $href = shift;
my $link = $self->{link} || [];
$link = [$link] if UNIVERSAL::isa( $link, 'HASH' );
$link = [ grep { ref $_ } @$link ];
$link = [ grep {
! exists $_->{'-rel'} || $_->{'-rel'} eq 'alternate'
} @$link ];
my $html = shift @$link;
if ( defined $href ) {
if ( ref $html ) {
$html->{'-href'} = $href;
}
else {
my $hash = {
# -rel => 'alternate',
-href => $href,
};
my $flink = $self->{link};
if ( ! ref $flink ) {
$self->{link} = [ $hash ];
}
elsif ( ref $flink && UNIVERSAL::isa( $flink, 'ARRAY' )) {
push( @$flink, $hash );
}
elsif ( ref $flink && UNIVERSAL::isa( $flink, 'HASH' )) {
$self->{link} = [ $flink, $hash ];
}
}
$self->guid( $href ) unless defined $self->guid();
}
elsif ( ref $html ) {
return $html->{'-href'};
}
return;
}
sub pubDate {
my $self = shift;
my $date = shift;
return $self->get_pubDate_w3cdtf() unless defined $date;
$date = XML::FeedPP::Util::get_w3cdtf($date);
$self->set_value( 'updated', $date );
}
sub get_pubDate_native {
my $self = shift;
$self->get_value('updated') # Atom 1.0
|| $self->get_value('published') # Atom 1.0
|| $self->get_value('issued') # Atom 0.3
|| $self->get_value('modified'); # Atom 0.3
}
*get_pubDate_w3cdtf = \&get_pubDate_native;
sub title {
my $self = shift;
my $title = shift;
my $type = shift || 'text';
return $self->get_value('title') unless defined $title;
$self->set_value( 'title' => $title, type => $type );
}
sub category {
my $self = shift;
if ( scalar @_ ) {
my $cate = ref $_[0] ? $_[0] : \@_;
my $list = [ map {+{-term=>$_}} @$cate ];
$self->{category} = ( scalar @$list > 1 ) ? $list : shift @$list;
}
else {
return unless exists $self->{category};
my $list = $self->{category} || [];
$list = [ $list ] if ( defined $list && ! UNIVERSAL::isa( $list, 'ARRAY' ));
my $term = [ map {ref $_ && exists $_->{-term} && $_->{-term} } @$list ];
# return wantarray ? @$term : shift @$term;
return ( scalar @$term > 1 ) ? $term : shift @$term;
}
}
# ----------------------------------------------------------------
package XML::FeedPP::Element;
use strict;
sub new {
my $package = shift;
my $self = {@_};
bless $self, $package;
$self;
}
sub ref_bless {
my $package = shift;
my $self = shift;
bless $self, $package;
$self;
}
sub set {
my $self = shift;
while ( scalar @_ ) {
my $key = shift @_;
my $val = shift @_;
my $node = $self;
while ( $key =~ s#^([^/]+)/##s ) {
my $child = $1;
if ( ref $node->{$child} ) {
# ok
}
elsif ( defined $node->{$child} ) {
$node->{$child} = { '#text' => $node->{$child} };
}
else {
$node->{$child} = {};
}
$node = $node->{$child};
}
my ( $tagname, $attr ) = split( /\@/, $key, 2 );
if ( $tagname eq "" && defined $attr ) {
$node->{ '-' . $attr } = $val;
}
elsif ( defined $attr ) {
if ( ref $node->{$tagname} &&
UNIVERSAL::isa( $node->{$tagname}, 'ARRAY' )) {
$node->{$tagname} = shift @{$node->{$tagname}};
}
my $hkey = '-' . $attr;
if ( ref $node->{$tagname} ) {
$node->{$tagname}->{$hkey} = $val;
}
elsif ( defined $node->{$tagname} ) {
$node->{$tagname} = {
'#text' => $node->{$tagname},
$hkey => $val,
};
}
else {
$node->{$tagname} = { $hkey => $val };
}
}
elsif ( defined $tagname ) {
if ( ref $node->{$tagname} &&
UNIVERSAL::isa( $node->{$tagname}, 'ARRAY' )) {
$node->{$tagname} = shift @{$node->{$tagname}};
}
if ( ref $node->{$tagname} ) {
$node->{$tagname}->{'#text'} = $val;
}
else {
$node->{$tagname} = $val;
}
}
}
}
sub get {
my $self = shift;
my $key = shift;
my $node = $self;
while ( $key =~ s#^([^/]+)/##s ) {
my $child = $1;
return unless ref $node;
return unless exists $node->{$child};
$node = $node->{$child};
}
my ( $tagname, $attr ) = split( /\@/, $key, 2 );
return unless ref $node;
# return unless exists $node->{$tagname};
if ( $tagname eq "" && defined $attr ) { # @attribute
return unless exists $node->{ '-' . $attr };
return $node->{ '-' . $attr };
}
elsif ( defined $attr ) { # node@attribute
return unless ref $node->{$tagname};
my $hkey = '-' . $attr;
if ( UNIVERSAL::isa( $node->{$tagname}, 'ARRAY' )) {
my $list = [
map { ref $_ && exists $_->{$hkey} ? $_->{$hkey} : undef }
@{$node->{$tagname}} ];
return @$list if wantarray;
return ( grep { defined $_ } @$list )[0];
}
return unless exists $node->{$tagname}->{$hkey};
return $node->{$tagname}->{$hkey};
}
else { # node
return $node->{$tagname} unless ref $node->{$tagname};
if ( UNIVERSAL::isa( $node->{$tagname}, 'ARRAY' )) {
my $list = [
map { ref $_ ? $_->{'#text'} : $_ }
@{$node->{$tagname}} ];
return @$list if wantarray;
return ( grep { defined $_ } @$list )[0];
}
return $node->{$tagname}->{'#text'};
}
}
sub get_set_array {
my $self = shift;
my $elem = shift;
my $value = shift;
if ( ref $value ) {
$self->{$elem} = $value;
} elsif ( defined $value ) {
$value = [ $value, @_ ] if scalar @_;
$self->{$elem} = $value;
} else {
my @ret = $self->get_value($elem);
return scalar @ret > 1 ? \@ret : $ret[0];
}
}
sub get_or_set {
my $self = shift;
my $elem = shift;
return scalar @_
? $self->set_value( $elem, @_ )
: $self->get_value($elem);
}
sub get_value {
my $self = shift;
my $elem = shift;
unless(exists $self->{$elem}) {
#XXX TreePP does not understand prefixes, which is usually not a
# problem because most clients break on them... "best practices"
# for feeds often explicitly state to use "the default" namespace.
# Let's try to ignore the namespace here.
($elem) = grep /\:\Q$elem\E$/, keys %$self;
defined $elem or return;
}
my $value = $self->{$elem};
return $value unless ref $value;
# multiple elements
if ( UNIVERSAL::isa( $value, 'ARRAY' )) {
if ( wantarray ) {
return map { $self->_fetch_value($_) } @$value;
} else {
return $self->_fetch_value($value->[0]);
}
}
return $self->_fetch_value($value);
}
sub _fetch_value {
my $self = shift;
my $value = shift;
if ( UNIVERSAL::isa( $value, 'HASH' )) {
# text node of an element with attributes
return defined $value->{'#text'}
? $self->_fetch_value($value->{'#text'})
: '';
}
if ( UNIVERSAL::isa( $value, 'SCALAR' )) {
# CDATA section as a scalar reference
return $$value;
}
return $value;
}
sub set_value {
my $self = shift;
my $elem = shift;
my $text = shift;
my $attr = \@_;
if ( UNIVERSAL::isa( $self->{$elem}, 'HASH' )) {
$self->{$elem}->{'#text'} = $text;
}
else {
$self->{$elem} = $text;
}
$self->set_attr( $elem, @$attr ) if scalar @$attr;
undef;
}
sub get_attr {
my $self = shift;
my $elem = shift;
my $key = shift;
return unless exists $self->{$elem};
return unless ref $self->{$elem};
return unless exists $self->{$elem}->{ '-' . $key };
$self->{$elem}->{ '-' . $key };
}
sub set_attr {
my $self = shift;
my $elem = shift;
my $attr = \@_;
if ( defined $self->{$elem} ) {
my $scalar = ref $self->{$elem};
$scalar = undef if ($scalar eq 'SCALAR');
if (! $scalar) {
$self->{$elem} = { '#text' => $self->{$elem} };
}
}
else {
$self->{$elem} = {};
}
while ( scalar @$attr ) {
my $key = shift @$attr;
my $val = shift @$attr;
if ( defined $val ) {
# $val = $$val if (ref $val eq 'SCALAR');
$self->{$elem}->{ '-' . $key } = $val;
}
else {
delete $self->{$elem}->{ '-' . $key };
}
}
undef;
}
# ----------------------------------------------------------------
package XML::FeedPP::Util;
use strict;
my ( @DoW, @MoY, %MoY );
@DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
@MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@MoY{ map { uc($_) } @MoY } = ( 1 .. 12 );
my $tz_now = time();
my $tz_offset = Time::Local::timegm( localtime($tz_now) ) -
Time::Local::timegm( gmtime($tz_now) );
my $tz_hour = int( $tz_offset / 3600 );
my $tz_min = int( $tz_offset / 60 ) % 60;
my $rfc1123_regexp = qr{
^(?:[A-Za-z]+,\s*)? (\d+)\s+ ([A-Za-z]+)\s+ (\d+)\s+
(\d+):(\d+)(?::(\d+)(?:\.\d*)?)?\s*
([\+\-]\d+:?\d{2} | [ECMP][DS]T )?
}xi;
my $w3cdtf_regexp = qr{
^(\d+)-(\d+)-(\d+)
(?:T(\d+):(\d+)(?::(\d+)(?:\.\d*)?\:?)?\s*
([\+\-]\d+:?\d{2})?|$)
}x;
my $tzmap = {qw(
EDT -4 EST -5 CDT -5 CST -6
MDT -6 MST -7 PDT -7 PST -8
)};
sub epoch_to_w3cdtf {
my $epoch = shift;
return unless defined $epoch;
my ( $sec, $min, $hour, $day, $mon, $year ) = gmtime($epoch+$tz_offset);
$year += 1900;
$mon++;
my $tz = $tz_offset ? sprintf( '%+03d:%02d', $tz_hour, $tz_min ) : 'Z';
sprintf( '%04d-%02d-%02dT%02d:%02d:%02d%s',
$year, $mon, $day, $hour, $min, $sec, $tz );
}
sub epoch_to_rfc1123 {
my $epoch = shift;
return unless defined $epoch;
my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = gmtime($epoch+$tz_offset);
$year += 1900;
my $tz = $tz_offset ? sprintf( '%+03d%02d', $tz_hour, $tz_min ) : 'GMT';
sprintf( '%s, %02d %s %04d %02d:%02d:%02d %s',
$DoW[$wday], $mday, $MoY[$mon], $year, $hour, $min, $sec, $tz );
}
sub rfc1123_to_w3cdtf {
my $str = shift;
return unless defined $str;
my ( $mday, $mon, $year, $hour, $min, $sec, $tz ) = ( $str =~ $rfc1123_regexp );
return unless ( $year && $mon && $mday );
$year += 2000 if $year < 77;
$year += 1900 if $year < 100;
$mon = $MoY{ uc($mon) } or return;
if ( defined $tz && $tz ne '' && $tz ne 'GMT' ) {
my $off = &get_tz_offset($tz) / 60;
$tz = sprintf( '%+03d:%02d', $off/60, $off%60 );
}
else {
$tz = 'Z';
}
sprintf( '%04d-%02d-%02dT%02d:%02d:%02d%s',
$year, $mon, $mday, $hour, $min, $sec, $tz );
}
sub w3cdtf_to_rfc1123 {
my $str = shift;
return unless defined $str;
my ( $year, $mon, $mday, $hour, $min, $sec, $tz ) = ( $str =~ $w3cdtf_regexp );
return unless ( $year > 1900 && $mon && $mday );
$hour ||= 0;
$min ||= 0;
$sec ||= 0;
my $epoch = eval { Time::Local::timegm( $sec, $min, $hour, $mday, $mon-1, $year ) }
or return;
my $wday = ( gmtime($epoch) )[6];
if ( defined $tz && $tz ne '' && $tz ne 'Z' ) {
my $off = &get_tz_offset($tz) / 60;
$tz = sprintf( '%+03d%02d', $off/60, $off%60 );
}
else {
$tz = 'GMT';
}
sprintf(
'%s, %02d %s %04d %02d:%02d:%02d %s',
$DoW[$wday], $mday, $MoY[ $mon - 1 ], $year, $hour, $min, $sec, $tz
);
}
sub rfc1123_to_epoch {
my $str = shift;
return unless defined $str;
my ( $mday, $mon, $year, $hour, $min, $sec, $tz ) = ( $str =~ $rfc1123_regexp );
return unless ( $year && $mon && $mday );
$year += 2000 if $year < 77;
$year += 1900 if $year < 100;
$mon = $MoY{ uc($mon) } or return;
my $epoch = eval { Time::Local::timegm( $sec, $min, $hour, $mday, $mon-1, $year ) }
or return;
$epoch -= &get_tz_offset( $tz );
$epoch;
}
sub w3cdtf_to_epoch {
my $str = shift;
return unless defined $str;
my ( $year, $mon, $mday, $hour, $min, $sec, $tz ) = ( $str =~ $w3cdtf_regexp );
return unless ( $year > 1900 && $mon && $mday );
$hour ||= 0;
$min ||= 0;
$sec ||= 0;
my $epoch = eval { Time::Local::timegm( $sec, $min, $hour, $mday, $mon-1, $year ) }
or return;
$epoch -= &get_tz_offset( $tz );
$epoch;
}
sub get_tz_offset {
my $tz = shift;
return 0 unless defined $tz;
return $tzmap->{$tz}*60*60 if exists $tzmap->{$tz};
return 0 unless( $tz =~ m/^([\+\-]?)(\d+):?(\d{2})$/ );
my( $pm, $ho, $mi ) = ( $1, $2, $3 );
my $off = $ho * 60 + $mi;
$off *= ( $pm eq "-" ) ? -60 : 60;
$off;
}
sub get_w3cdtf {
my $date = shift;
return unless defined $date;
if ( $date =~ /^\d+$/s ) {
return &epoch_to_w3cdtf($date);
}
elsif ( $date =~ $rfc1123_regexp ) {
return &rfc1123_to_w3cdtf($date);
}
elsif ( $date =~ $w3cdtf_regexp ) {
return $date;
}
undef;
}
sub get_rfc1123 {
my $date = shift;
return unless defined $date;
if ( $date =~ /^\d+$/s ) {
return &epoch_to_rfc1123($date);
}
elsif ( $date =~ $rfc1123_regexp ) {
return $date;
}
elsif ( $date =~ $w3cdtf_regexp ) {
return &w3cdtf_to_rfc1123($date);
}
undef;
}
sub get_epoch {
my $date = shift;
return unless defined $date;
if ( $date =~ /^\d+$/s ) {
return $date;
}
elsif ( $date =~ $rfc1123_regexp ) {
return &rfc1123_to_epoch($date);
}
elsif ( $date =~ $w3cdtf_regexp ) {
return &w3cdtf_to_epoch($date);
}
undef;
}
sub merge_hash {
my $base = shift or return;
my $merge = shift or return;
my %exclude = map { $_ => 1 } @_;
foreach my $key ( keys %$merge ) {
next if $exclude{$key} || exists $base->{$key};
$base->{$key} = $merge->{$key};
}
}
sub param_even_odd {
if ( (scalar @_) % 2 == 0 ) {
# even num of args - new( key1 => val1, key2 => arg2 );
my $array = [ @_ ];
return $array;
}
else {
# odd num of args - new( first, key1 => val1, key2 => arg2 );
return ( undef, @_ );
}
}
# ----------------------------------------------------------------
1;
# ----------------------------------------------------------------