File Coverage

blib/lib/XML/SAX/Builder.pm

Criterion	Covered	Total	%
statement	212	213	99.5
branch	34	46	73.9
condition	25	42	59.5
subroutine	55	55	100.0
pod	8	8	100.0
total	334	364	91.7

# @(#) $Id: Builder.pm,v 1.4 2003/04/24 12:48:43 dom Exp $
package XML::SAX::Builder;

use strict;
use warnings;

use Carp qw( croak );
use XML::NamespaceSupport;
use XML::SAX::Writer;

our $VERSION = '0.02';
our $AUTOLOAD;

sub new {
    my $class = shift;
    # Escape hatch.
    return XML::SAX::Builder::Tag->new( $class->{Handler}, 'new', @_ )
        if ref $class;
    my ( $handler, %opts ) = @_;

    # Default to spitting out XML to STDOUT.
    $handler ||= XML::SAX::Writer->new;
    bless { Handler => $handler, %opts }, $class;
}

sub AUTOLOAD {
    my $self = shift;
    my @args = @_;
    my $tag  = $AUTOLOAD;
    $tag =~ s/.*:://;
    return if $tag eq 'DESTROY';
    $tag = "$self->{Prefix}:$tag"
        if $self->{Prefix};
    XML::SAX::Builder::Tag->new( $self->{ Handler }, $tag, @args );
}

# Start a new namespace.
sub xmlns {
    my $self = shift;
    XML::SAX::Builder::Namespace->new( $self->{ Handler }, @_ );
}

# Output unescaped stuff.
sub xmlcdata {
    my $self = shift;
    XML::SAX::Builder::CDATA->new( $self->{ Handler }, @_ );
}

# Output an XML DOCTYPE
sub xmldtd {
    my $self = shift;
    XML::SAX::Builder::Doctype->new( $self->{ Handler }, @_ );
}

# Output an XML comment
sub xmlcomment {
    my $self = shift;
    XML::SAX::Builder::Comment->new( $self->{ Handler }, @_ );
}

# Output an XML Processing Instruction.
sub xmlpi {
    my $self = shift;
    XML::SAX::Builder::ProcessingInstruction->new( $self->{ Handler }, @_ );
}

# Return a new generator which will automatically prefix elements.
sub xmlprefix {
    my $self = shift;
    my ($prefix) = @_;
    croak "usage: xmlprefix(prefix)"
        unless $prefix;
    my $class = ref $self;
    return $class->new( $self->{Handler}, Prefix => $prefix );
}

sub _only_one_element {
    my $self = shift;
    my ( @builders ) = @_;

    # A namespace only allows one element child, so this rule is
    # effectively propogated downwards.
    my @tag = grep {
           ref eq 'XML::SAX::Builder::Tag'
        || ref eq 'XML::SAX::Builder::Namespace'
    } @builders;
    return @tag == 1;
}

# Finalise the document.
sub xml {
    my $self = shift;
    my ( @builders ) = @_;
    croak "one and only one root element allowed"
        unless $self->_only_one_element( @builders );
    $self->{ Handler }->start_document( {} );
    my $nsup = XML::NamespaceSupport->new( { xmlns => 1 } );
    $nsup->push_context;
    foreach ( @builders ) {
        if ( ref && $_->can( 'run' ) ) {
            $_->run( $nsup );
        } else {
            $self->{ Handler }->characters( $_ );
        }
    }
    $self->{ Handler }->end_document( {} );
}

#---------------------------------------------------------------------

package XML::SAX::Builder::Base;
use strict;
use warnings;

sub new {
    my ( $class, $handler, @args ) = @_;
    bless $class->_make_closure( $handler, @args ), $class;
}

sub run { shift->(@_) }

sub is_valid_name {
    local $_ = $_[1];
    # This is deliberately very simplistic...
    return m/^[\w:][\w:.-]*$/;
}

sub _is_reserved_name {
    local $_ = $_[1];
    return m/^xml/i;
}

sub _is_valid_lang {
    local $_ = $_[1];
    return m/^
    (
      [a-zA-Z][a-zA-Z]  # ISO639Code
      |
      i-[a-zA-Z]+       # IanaCode
      |
      x-[a-zA-Z]+       # UserCode
    )
    (-[a-zA-Z]+)*       # Subcode
    $/x;
}

#---------------------------------------------------------------------

package XML::SAX::Builder::Tag;
use strict;
use warnings;
use base 'XML::SAX::Builder::Base';

sub _make_closure {
    my $class = shift;
    my ( $handler, $tag, @args ) = @_;
    Carp::croak "names beginning with /xml/i are reserved"
        if $class->_is_reserved_name( $tag );
    Carp::croak "doctype must appear before the first element"
        if grep { ref eq 'XML::SAX::Builder::Doctype' } @args;
    Carp::croak "invalid character in name"
        unless $class->is_valid_name( $tag );
    return sub {
        my ($self, $nsup) = @_;
        Carp::croak "usage self->(nsup)"
            unless $self && $nsup;
        my $data = $self->_make_element_data( $nsup, $tag );
        $nsup->push_context;
        $self->_add_attributes( $nsup, $data, shift @args )
            if $args[0] && ref $args[0] eq 'HASH';
        $handler->start_element( $data );
        foreach ( @args ) {
            if ( ref && $_->can( 'run' ) ) {
                $_->run( $nsup );
            } else {
                $handler->characters( { Data => $_ } );
            }
        }
        $handler->end_element( $data );
        $nsup->pop_context;
    };
}

sub _make_element_data {
    my $self = shift;
    my ( $nsup, $tag ) = @_;
    my ( $uri, $prefix, $lname ) = $nsup->process_element_name( $tag );
    $uri ||= ''; $prefix ||= ''; $lname ||= '';
    my $data = {
        LocalName    => $lname,
        Name         => $tag,
        NamespaceURI => $uri,
        Prefix       => $prefix,
    };
    $self->_add_namespace_attributes( $nsup, $data );
    return $data;
}

sub _add_namespace_attributes {
    my $self = shift;
    my ( $nsup, $data ) = @_;
    my %new_namespaces =
        map { $_ => $nsup->get_uri( $_ ) } $nsup->get_declared_prefixes;
    foreach my $prefix ( keys %new_namespaces ) {
        my $xmlns = length( $prefix ) ? "xmlns:$prefix" : "xmlns";
        $new_namespaces{ $xmlns } = delete $new_namespaces{ $prefix };
    }
    $self->_add_attributes( $nsup, $data, \%new_namespaces );
}

sub _add_attributes {
    my $self = shift;
    my ( $nsup, $data, $attr ) = @_;
    Carp::croak "invalid LanguageID"
        if $attr->{'xml:lang'} && !$self->_is_valid_lang( $attr->{'xml:lang'} );
    foreach ( keys %$attr ) {
        my ($uri, $prefix, $lname) = $nsup->process_attribute_name( $_ );
        $uri ||= ''; $prefix ||= ''; $lname ||= '';
        $data->{ Attributes }->{ "{$uri}$_" } = {
            Name         => $_,
            LocalName    => $lname,
            Prefix       => $prefix,
            NamespaceURI => $uri,
            Value        => $attr->{ $_ },
        };
    }
}

#---------------------------------------------------------------------

package XML::SAX::Builder::Namespace;
use strict;
use warnings;
use base 'XML::SAX::Builder::Base';

sub _make_closure {
    my $class = shift;
    my ( $handler, $prefix, $uri, @args ) = @_;
    my $child = $args[0];
    Carp::croak "new(handler,prefix,uri,child)"
        unless $handler && defined $prefix && $uri && $child;
    Carp::croak "Only one child of a namespace element is permitted"
        if @args > 1;
    Carp::croak "Namespace child must be element or namespace: $child"
        unless ref($child) eq 'XML::SAX::Builder::Tag' || ref($child) eq __PACKAGE__;
    return sub {
        my ( $self, $nsup ) = @_;
        $nsup->declare_prefix( $prefix => $uri );
        my $data = {
            Prefix       => $prefix,
            NamespaceURI => $uri,
        };
        $handler->start_prefix_mapping( $data );
        $child->run( $nsup );
        $handler->end_prefix_mapping( $data );
    };
}

#---------------------------------------------------------------------

package XML::SAX::Builder::CDATA;
use strict;
use warnings;
use base 'XML::SAX::Builder::Base';

sub _make_closure {
    my ( $class, $handler, @args ) = @_;
    Carp::croak "arguments must be character data only"
        if grep { ref } @args;
    @args = grep { defined } @args;
    return sub {
        my ( $self, $nsup ) = @_;
        $handler->start_cdata( {} );
        $handler->characters( { Data => join ( '', @args ) } );
        $handler->end_cdata( {} );
    };
}

#---------------------------------------------------------------------

package XML::SAX::Builder::Doctype;
use strict;
use warnings;
use base 'XML::SAX::Builder::Base';

sub _make_closure {
    my ( $class, $handler, $name, $system, $public ) = @_;
    Carp::croak "doctype: must specify name"      unless $name;
    Carp::croak "doctype: must specify system id" unless $system;
    return sub {
        my ( $self, $nsup ) = @_;
        my $data = {
            Name     => $name,
            PublicId => $public,
            SystemId => $system,
        };
        $handler->start_dtd( $data );
        $handler->end_dtd( $data );
    }
}

#---------------------------------------------------------------------

package XML::SAX::Builder::Comment;
use strict;
use warnings;
use base 'XML::SAX::Builder::Base';

sub _make_closure {
    my ( $class, $handler, $data ) = @_;
    return sub {
        my ( $self, $nsup ) = @_;
        $handler->comment( { Data => $data } );
    }
}

#---------------------------------------------------------------------

package XML::SAX::Builder::ProcessingInstruction;
use strict;
use warnings;
use base 'XML::SAX::Builder::Base';

sub _make_closure {
    my ( $class, $handler, $target, $data ) = @_;
    Carp::croak "usage: xmlpi(target,data)"
        unless @_ == 4;
    Carp::croak "names beginning with /xml/i are reserved"
        if $class->_is_reserved_name( $target );
    return sub {
        my ( $self, $nsup ) = @_;
        $handler->processing_instruction( {
            Target => $target,
            Data   => $data,
        } );
    }
}

1;
__END__