File Coverage

blib/lib/XML/Genx/SAXWriter.pm

Criterion	Covered	Total	%
statement	99	101	98.0
branch	21	24	87.5
condition	8	17	47.0
subroutine	24	24	100.0
pod	10	10	100.0
total	162	176	92.0

package XML::Genx::SAXWriter;

use strict;
use warnings;

use Carp ();
use XML::Genx::Simple;

use base 'XML::SAX::Base';

our $VERSION = '0.22';

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

sub _init {
    my $self = shift;
    my %opt = @_;
    $self->_out( $opt{ out } || \*STDOUT );
    return;
}

sub start_document {
    my $self = shift;

    $self->_w( XML::Genx::Simple->new );

    if ( ref $self->_out eq 'SCALAR' ) {
        $self->_w->StartDocString;
    } elsif ( ref $self->_out eq 'GLOB' ) {
        $self->_w->StartDocFile( $self->_out );
    } elsif ( ref $self->_out eq 'CODE' ) {
        $self->_w->StartDocSender( $self->_out );
    } elsif ( ref $self->_out && $self->_out->isa( 'IO::Handle' ) ) {
        $self->_w->StartDocFile( $self->_out );
    } elsif ( defined $self->_out && length $self->_out ) {
        open( my $fh, '>', $self->_out )
          or Carp::croak( "open(".$self->_out."): $!" );
        $self->_w->StartDocFile( $fh );
    } else {
        Carp::croak( "start_document: no output specified!" );
    }
}

sub end_document {
    my $self = shift;
    my $rv = $self->_w->EndDocument;
    if ( ref $self->_out eq 'SCALAR' ) {
        ${ $self->_out } = $self->_w->GetDocString;
    }
    return $rv;
}

sub start_element {
    my $self = shift;
    my ( $data ) = @_;

    my $ns =
        $self->_new_namespace( $data->{ NamespaceURI }, $data->{ Prefix } );
    $self->_new_element( $ns, $data->{ LocalName } )->StartElement;

    while ( my $ns = $self->_pop_ns ) {
        # In order to get default namespaces done correctly, we have to
        # specify the prefix explicitly to AddNamespace().  See comments
        # above _declare_namespace().
        my ( $uri, $prefix ) = @$ns;
        $self->_new_namespace( $uri, $prefix )->AddNamespace( $prefix );
    }

    foreach ( values %{ $data->{ Attributes } || {} } ) {
        my $ns = $self->_new_namespace( $_->{ NamespaceURI }, $_->{ Prefix } );
        $self->_new_attribute( $ns, $_->{ LocalName } )
            ->AddAttribute( $_->{ Value } );
    }

    return;
}

sub characters {
    my $self = shift;
    my ( $data ) = @_;
    $self->_w->AddText( $data->{ Data } );
}

sub end_element {
    my $self = shift;
    my ( $data ) = @_;
    $self->_w->EndElement;
}

sub start_prefix_mapping {
    my $self = shift;
    my ( $data ) = @_;
    $self->_push_ns( $data->{ NamespaceURI }, $data->{ Prefix } );
}

sub end_prefix_mapping {
    my $self = shift;
    my ( $data ) = @_;
    # XXX Do we need to do anything here?  I don't think so.
}

sub processing_instruction {
    my $self = shift;
    my ( $data ) = @_;
    $self->_w->PI( $data->{ Target }, $data->{ Data } );
}

sub comment {
    my $self = shift;
    my ( $data ) = @_;
    $self->_w->Comment( $data->{ Data } );
}

#---------------------------------------------------------------------
# PRIVATE
#---------------------------------------------------------------------

sub _w {
    my $self = shift;
    if ( @_ ) {
        $self->{ _w } = $_[0];
        return $self;
    } else {
        return $self->{ _w };
    }
}

sub _out {
    my $self = shift;
    if ( @_ ) {
        $self->{ _out } = $_[0];
        return $self;
    } else {
        return $self->{ _out };
    }
}

sub _push_ns {
    my $self = shift;
    my ( $ns, $prefix ) = @_;
    push @{ $self->{ nstodo } }, [$ns, $prefix];
    return;
}

sub _pop_ns {
    my $self = shift;
    return pop @{ $self->{ nstodo } };
}

# Return a declared namespace object if it's present.  If no namespace
# is given, return undef.
sub _new_namespace {
    my $self = shift;
    my ( $nsuri, $prefix ) = @_;
    return unless $nsuri;
    return $self->{ namespace }{ $nsuri } ||=
        $self->_declare_namespace( $nsuri, $prefix );
}

# Get Genx to give us a new namespace object.  NB: If a default
# namespace is requested, we ask Genx to assign an autogenerated prefix
# instead.  This gets countered further up in start_element().  When we
# call AddNamespace(), we pass in the requested prefix instead, which
# will be "" in case of the default namespace.  This is all in order to
# work around Genx, which will not let you declare two namespaces with
# the default prefix.
sub _declare_namespace {
    my $self = shift;
    my ( $nsuri, $prefix ) = @_;
    if ( $prefix ) {
        return $self->_w->DeclareNamespace( $nsuri, $prefix );
    } else {
        return $self->_w->DeclareNamespace( $nsuri );
    }
}

sub _new_element {
    my $self = shift;
    my ( $ns, $lname ) = @_;
    return $self->{ element }{ $lname } ||=
        $self->_w->DeclareElement( $ns, $lname );
}

sub _new_attribute {
    my $self = shift;
    my ( $ns, $lname ) = @_;
    return $self->{ attribute }{ $lname } ||=
        $self->_w->DeclareAttribute( $ns, $lname );
}

1;
__END__