File Coverage

blib/lib/XML/Atom/SimpleFeed.pm

Criterion	Covered	Total	%
statement	143	170	84.1
branch	48	86	55.8
condition	13	25	52.0
subroutine	31	34	91.1
pod	4	25	16.0
total	239	340	70.2

use 5.008001; # no good Unicode support? you lose
use strict;
use warnings;

package XML::Atom::SimpleFeed;
our $VERSION = '0.905';

use Carp;
use Encode ();
use POSIX ();

my @XML_ENC = 'us-ascii'; # use array because local($myvar) error but local($myvar[0]) OK
                          # and use a lexical because not a public interface

sub ATOM_NS           () { 'http://www.w3.org/2005/Atom' }
sub XHTML_NS          () { 'http://www.w3.org/1999/xhtml' }
sub PREAMBLE          () { qq(\n) }
sub W3C_DATETIME      () { '%Y-%m-%dT%H:%M:%S' }
sub DEFAULT_GENERATOR () { {
	uri     => 'https://metacpan.org/pod/' . __PACKAGE__,
	version => __PACKAGE__->VERSION || 'git',
	name    => __PACKAGE__,
} }

####################################################################
# superminimal XML writer
#

sub xml_encoding { local $XML_ENC[0] = shift; &{(shift)} }

my %XML_ESC = (
	"\xA" => '
',
	"\xD" => '
',
	'"'   => '"',
	'&'   => '&',
	"'"   => ''',
	'<'   => '<',
	'>'   => '>',
);

sub xml_cref { Encode::encode $XML_ENC[0], $_[0], Encode::HTMLCREF }

sub xml_escape {
	$_[0] =~ s{ ( [<>&'"] ) }{ $XML_ESC{ $1 } }gex;
	&xml_cref;
}

sub xml_attr_escape {
	$_[0] =~ s{ ( [\x0A\x0D<>&'"] ) }{ $XML_ESC{ $1 } }gex;
	&xml_cref;
}

sub xml_cdata_flatten {
	for ( $_[0] ) {
		my $cdata_content;
		s{}{ xml_escape $cdata_content = $1 }gse;
		croak 'Incomplete CDATA section' if -1 < index $_, '
		return $_;
	}
}

sub xml_string { xml_cref xml_cdata_flatten $_[ 0 ] }

sub xml_tag {
	my $name = shift;
	my $attr = '';
	if( ref $name eq 'ARRAY' ) {
		my $i = 1;
		while( $i < @$name ) {
			$attr .= ' ' . $name->[ $i ] . '="' . xml_attr_escape( $name->[ $i + 1 ] ) . '"';
			$i += 2;
		}
		$name = $name->[ 0 ];
	}
	@_ ? join( '', "<$name$attr>", @_, "" ) : "<$name$attr/>";
}

####################################################################
# misc utility functions
#

sub natural_enum {
	my @and;
	unshift @and, pop @_ if @_;
	unshift @and, join ', ', @_ if @_;
	join ' and ', @and;
}

sub permalink {
	my ( $link_arg ) = ( @_ );
	if( ref $link_arg ne 'HASH' ) {
		return $link_arg;
	}
	elsif( not exists $link_arg->{ rel } or $link_arg->{ rel } eq 'alternate' ) {
		return $link_arg->{ href };
	}
	return;
}

####################################################################
# actual implementation of RFC 4287
#

sub simple_construct {
	my ( $name, $content ) = @_;
	xml_tag $name, xml_escape $content;
}

sub date_construct {
	my ( $name, $dt ) = @_;
	eval { $dt = $dt->epoch }; # convert to epoch to avoid dealing with everyone's TZ crap
	$dt = POSIX::strftime( W3C_DATETIME . 'Z', gmtime $dt ) unless $dt =~ /[^0-9]/;
	xml_tag $name, xml_escape $dt;
}

sub person_construct {
	my ( $name, $arg ) = @_;

	my $prop = 'HASH' ne ref $arg ? { name => $arg } : $arg;

	croak "name required for $name element" if not exists $prop->{ name };

	return xml_tag $name => (
		map { xml_tag $_ => xml_escape $prop->{ $_ } }
		grep { exists $prop->{ $_ } }
		qw( name email uri )
	);
}

sub text_construct {
	my ( $name, $arg ) = @_;

	my ( $type, $content );

	if( ref $arg eq 'HASH' ) {
		# FIXME doesn't support @src attribute for $name eq 'content' yet

		$type = exists $arg->{ type } ? $arg->{ type } : 'html';

		croak "content required for $name element" unless exists $arg->{ content };

		# a lof of the effort that follows is to omit the type attribute whenever possible
		#
		if( $type eq 'xhtml' ) {
			$content = xml_string $arg->{ content };

			if( $content !~ /
				$type = 'text';
				$content =~ s/[\n\t]+/ /g;
			}
			else {
				$content = xml_tag [ div => xmlns => XHTML_NS ], $content;
			}
		}
		elsif( $type eq 'html' or $type eq 'text' ) {
			$content = xml_escape $arg->{ content };
		}
		else {
			croak "type '$type' not allowed in $name element"
				if $name ne 'content';

			# FIXME non-XML/text media types must be base64 encoded!
			$content = xml_string $arg->{ content };
		}
	}
	else {
		$type = 'html';
		$content = xml_escape $arg;
	}

	if( $type eq 'html' and $content !~ /&/ ) {
		$type = 'text';
		$content =~ s/[\n\t]+/ /g;
	}

	return xml_tag [ $name => $type ne 'text' ? ( type => $type ) : () ], $content;
}

sub link_element {
	my ( $name, $arg ) = @_;

	# omit atom:link/@rel value when possible
	delete $arg->{'rel'}
		if 'HASH' eq ref $arg
		and exists $arg->{'rel'}
		and 'alternate' eq $arg->{'rel'};

	my @attr = 'HASH' eq ref $arg
		? do {
			croak "href required for link element" if not exists $arg->{'href'};
			map { $_ => $arg->{ $_ } } grep exists $arg->{ $_ }, qw( href rel type title hreflang length );
		}
		: ( href => $arg );

	# croak "link '$attr[1]' is not a valid URI"
	# 	if $attr[1] XXX TODO

	xml_tag [ link => @attr ];
}

sub category_element {
	my ( $name, $arg ) = @_;

	my @attr = 'HASH' eq ref $arg
		? do {
			croak "term required for category element" if not exists $arg->{'term'};
			map { $_ => $arg->{ $_ } } grep exists $arg->{ $_ }, qw( term scheme label );
		}
		: ( term => $arg );

	xml_tag [ category => @attr ];
}

sub generator_element {
	my ( $name, $arg ) = @_;
	if( ref $arg eq 'HASH' ) {
		croak 'name required for generator element' if not exists $arg->{ name };
		my $content = delete $arg->{ name };
		xml_tag [ generator => map +( $_ => $arg->{ $_ } ), grep exists $arg->{ $_ }, qw( uri version ) ], xml_escape( $content );
	}
	elsif( defined $arg ) {
		xml_tag generator => xml_escape( $arg );
	}
	else { '' }
}

# tag makers are called with the name of the tag they're supposed to handle as the first parameter
my %make_tag = (
	icon        => \&simple_construct,
	id          => \&simple_construct,
	logo        => \&simple_construct,
	published   => \&date_construct,
	updated     => \&date_construct,
	author      => \&person_construct,
	contributor => \&person_construct,
	title       => \&text_construct,
	subtitle    => \&text_construct,
	rights      => \&text_construct,
	summary     => \&text_construct,
	content     => \&text_construct,
	link        => \&link_element,
	category    => \&category_element,
	generator   => \&generator_element,
);

sub container_content {
	my ( $name, %arg ) = @_;

	my ( $elements, $required, $optional, $singular, $deprecation, $callback ) =
		@arg{ qw( elements required optional singular deprecate callback ) };

	my ( $content, %permission, %count, $permalink );

	undef @permission{ @$required, @$optional }; # populate

	while( my ( $elem, $arg ) = splice @$elements, 0, 2 ) {
		if( exists $permission{ $elem } ) {
			$content .= $make_tag{ $elem }->( $elem, $arg );
			++$count{ $elem };
		}
		else {
			croak "Unknown element $elem";
		}

		if( $elem eq 'link' and defined ( my $alt = permalink $arg ) ) {
			$permalink = $alt unless $count{ 'alternate link' }++;
		}

		if( exists $callback->{ $elem } ) { $callback->{ $elem }->( $arg ) }

		if( not @$elements ) { # end of input?
			# we would normally fall off the bottom of the loop now;
			# before that happens, it's time to defaultify stuff and
			# put it in the input so we will keep going for a little longer
			if( not $count{ id } and defined $permalink ) {
				carp 'Falling back to alternate link as id';
				push @$elements, id => $permalink;
			}
			if( not $count{ updated } ) {
				push @$elements, updated => $arg{ default_upd };
			}
		}
	}

	my @error;

	my @missing = grep { not exists $count{ $_ } } @$required;
	my @toomany = grep { ( $count{ $_ } || 0 ) > 1 } 'alternate link', @$singular;

	push @error, 'requires at least one ' . natural_enum( @missing ) . ' element' if @missing;
	push @error, 'must have no more than one ' . natural_enum( @toomany ) . ' element' if @toomany;

	croak $name, ' ', join ' and ', @error if @error;

	return $content;
}

####################################################################
# implementation of published interface and rest of RFC 4287
#

sub XML::Atom::SimpleFeed::new {
	my $self = bless { xml_encoding => $XML_ENC[0] }, shift;

	if ( my @i = grep { '-encoding' eq $_[$_] } grep { not $_ % 2 } 0 .. $#_ ) {
		croak 'multiple encodings requested' if @i > 1;
		( undef, my $encoding ) = splice @_, $i[0], 2;
		$self->{ xml_encoding } = $encoding;
	}

	@_ ? $self->feed( @_ ) : $self;
}

sub XML::Atom::SimpleFeed::feed {
	my $self = shift;

	my $have_generator;

	local $XML_ENC[0] = $self->{ xml_encoding };
	$self->{ meta } = container_content feed => (
		elements    => \@_,
		required    => [ qw( id title updated ) ],
		optional    => [ qw( author category contributor generator icon logo link rights subtitle ) ],
		singular    => [ qw( generator icon logo id rights subtitle title updated ) ],
		callback    => {
			author    => sub { $self->{ have_default_author } = 1 },
			updated   => sub { $self->{ global_updated } = $_[ 0 ] },
			generator => sub { $have_generator = 1 },
		},
		default_upd => time,
	);

	$self->{ meta } .= $make_tag{ generator }->( generator => DEFAULT_GENERATOR )
		unless $have_generator;

	return $self;
}

sub XML::Atom::SimpleFeed::add_entry  {
	my $self = shift;

	my @required = qw( id title updated );
	my @optional = qw( category content contributor link published rights summary );

	push @{ $self->{ have_default_author } ? \@optional : \@required }, 'author';

	# FIXME
	#
	# o  atom:entry elements that contain no child atom:content element
	#    MUST contain at least one atom:link element with a rel attribute
	#    value of "alternate".
	#
	# o  atom:entry elements MUST contain an atom:summary element in either
	#    of the following cases:
	#    *  the atom:entry contains an atom:content that has a "src"
	#       attribute (and is thus empty).
	#    *  the atom:entry contains content that is encoded in Base64;
	#       i.e., the "type" attribute of atom:content is a MIME media type
	#       [MIMEREG], but is not an XML media type [RFC3023], does not
	#       begin with "text/", and does not end with "/xml" or "+xml".

	local $XML_ENC[0] = $self->{ xml_encoding };
	push @{ $self->{ entries } }, xml_tag entry => container_content entry => (
		elements    => \@_,
		required    => \@required,
		optional    => \@optional,
		singular    => [ qw( content id published rights summary ) ],
		default_upd => $self->{ global_updated },
	);

	return $self;
}

sub XML::Atom::SimpleFeed::as_string {
	my $self = shift;
	local $XML_ENC[0] = $self->{ xml_encoding };
	PREAMBLE . xml_tag [ feed => xmlns => ATOM_NS ], $self->{ meta }, @{ $self->{ entries } };
}

sub XML::Atom::SimpleFeed::print {
	my $self = shift;
	my ( $handle ) = @_;
	local $, = local $\ = '';
	defined $handle ? print $handle $self->as_string : print $self->as_string;
}

sub XML::Atom::SimpleFeed::save_file { croak q{no longer supported, use 'print' instead and pass in a filehandle} }

!!'Funky and proud of it.';

__END__