File Coverage

blib/lib/XML/Atom/Syndication/Writer.pm

Criterion	Covered	Total	%
statement	57	62	91.9
branch	13	20	65.0
condition	4	9	44.4
subroutine	11	13	84.6
pod	6	8	75.0
total	91	112	81.2

package XML::Atom::Syndication::Writer;
use strict;

use base qw( Class::ErrorHandler );

use XML::Writer;
use XML::Elemental::Util qw( process_name );

my %NSPrefix = (    # default prefix table.
                    # ''        => "http://www.w3.org/2005/Atom",
    dc        => "http://purl.org/dc/elements/1.1/",
    dcterms   => "http://purl.org/dc/terms/",
    sy        => "http://purl.org/rss/1.0/modules/syndication/",
    trackback => "http://madskills.com/public/xml/rss/module/trackback/",
    xhtml     => "http://www.w3.org/1999/xhtml",
    xml       => "http://www.w3.org/XML/1998/namespace"
);

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->init(@_);
}

sub init {
    my %nsp = %NSPrefix;    # clone
    $_[0]->{__PREFIX} = \%nsp;
    $_[0]->{__NS}     = {reverse %nsp};
    $_[0];
}

sub set_prefix {
    $_[0]->{__NS}->{$_[2]}     = $_[1];
    $_[0]->{__PREFIX}->{$_[1]} = $_[2];
}

sub get_prefix    { $_[0]->{__NS}->{$_[1]} }
sub get_namespace { $_[0]->{__PREFIX}->{$_[1]} }

sub no_cdata {
    if (defined $_[1]) {
        $_[0]->{__NO_CDATA} = $_[1] ? 1 : 0;
    }
    $_[0]->{__NO_CDATA};
}

sub as_xml {
    my ($self, $node, $is_full) = @_;
    my $xml = '';
    my $w;
    if ($is_full) {    # full doc
        my ($name, $ns) = process_name($node->name);
        $w = XML::Writer->new(
            OUTPUT => \$xml,
            UNSAFE => 1,      # consequence of not using buggy characters method
            NAMESPACES => 1,
            PREFIX_MAP => $self->{__NS},    # FORCED_NS_DECLS => [ $ns ]
        );
        $w->xmlDecl('utf-8');
    } else {    # fragment
        $w = XML::Writer->new(OUTPUT => \$xml, UNSAFE => 1);
    }
    my $dumper;
    $dumper = sub {
        my $node = shift;
        return encode_xml($w, $node->data, $self->{__NO_CDATA})
          if (ref $node eq 'XML::Elemental::Characters');
        my ($name, $ns) =
          process_name($node->name);    # it must be an element then.
        my $tag = $is_full ? [$ns, $name] : $name;
        my @attr;
        my $a        = $node->attributes;
        my $children = $node->contents;
        foreach (keys %$a) {
            my ($aname, $ans) = process_name($_);
            next
              if (   $ans eq 'http://www.w3.org/2000/xmlns/'
                  || $aname eq 'xmlns');
            my $key = $is_full && $ans ? [$ans, $aname] : $aname;
            push @attr, $key, $a->{$_};
        }
        if (@$children) {
            $w->startTag($tag, @attr);
            $dumper->($_) for @$children;
            $w->endTag($tag);
        } else {
            $w->emptyTag($tag, @attr);
        }
    };
    $dumper->($node);

    # $w->end; # this adds a character return we don't want.
    $xml;
}

my %Map = (
           '&'  => '&',
           '"'  => '"',
           '<'  => '<',
           '>'  => '>',
           '\'' => '''
);
my $RE = join '|', keys %Map;

sub encode_xml
{    # XML::Writer::character encoding is wrong so we handle this ourselves.
    my ($w, $str, $nocdata) = @_;
    return '' unless defined $str;
    if (
        !$nocdata
        && $str =~ m/
        <[^>]+>  ## HTML markup
        |        ## or
        &(?:(?!(\#([0-9]+)|\#x([0-9a-fA-F]+))).*?);
                 ## something that looks like an HTML entity.
    /x
      ) {
        ## If ]]> exists in the string, encode the > to >.
        $str =~ s/]]>/]]>/g;
        $str = '';
      } else {
        $str =~ s!($RE)!$Map{$1}!g;
    }
    $w->raw($str);    # forces UNSAFE mode at all times.
}

1;

__END__