view release on metacpan or  search on metacpan

lib/XML/Atom/SimpleFeed.pm  view on Meta::CPAN

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(<?xml version="1.0" encoding="$XML_ENC[0]"?>\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" => '&#10;',
	"\xD" => '&#13;',
	'"'   => '&#34;',
	'&'   => '&#38;',
	"'"   => '&#39;',
	'<'   => '&lt;',
	'>'   => '&gt;',
);

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{<!\[CDATA\[(.*?)]]>}{ xml_escape $cdata_content = $1 }gse;
		croak 'Incomplete CDATA section' if -1 < index $_, '<![CDATA[';
		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>" ) : "<$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 };