XML::SAX::Builder - build XML documents using SAX

XML-SAX-Builder documentation Contained in the XML-SAX-Builder distribution.

Index

Code Index:

NAME

Top

XML::SAX::Builder - build XML documents using SAX

SYNOPSIS

Top

  my $x = XML::SAX::Builder->new;
  $x->xml( $x->foo( 'bar' ) );

  # Produces:
  # <foo>bar</foo>

  $x->xml( $x->foo( { id => 1 }, 'bar' ) );

  # Produces:
  # <foo id='1'>bar</foo>

  $x->xml( $x->foo( $x->bar(1), 'middle', $x->baz ) );

  # Produces:
  # <foo><bar>1</bar>middle<baz /></foo>

  $x->xml( $x->xmlns( '' => 'urn:foo', $x->foo( 'bar' ) ) );

  # Produces:
  # <foo xmlns='urn:foo'>bar</foo>

  my $pfx = $x->xmlprefix( 'pfx' );
  $x->xml( $x->xmlns( foo => 'urn:foo', $pfx->foo( 'bar' ) ) );

  # Produces:
  # <pfx:foo xmlns:pfx='urn:foo'>bar</pfx:foo>

DESCRIPTION

Top

This module is a set of classes to allow easy construction of XML documents, in particular in association with an XML::SAX pipeline. The default is to output the XML to stdout, although this is easily changed.

METHODS

Top

new ( [ HANDLER ] )

Return a new builder object. Optionall, a SAX HANDLER may be passed in. If none is passed in, the default is to use an XmL::SAX::Writer instead. The default configuration for XML::SAX::Writer sends XML to STDOUT. If you wish to get XML sent elsewhere, supply your own XML::SAX::Writer object.

element ( [ [ ATTRS ], OBJ, ... ] )

Any element may be produced by calling it as a method on the Builder object. Each argument may be a previously created element, or a piece of text.

Optionally, the first argument may be a hash reference. If so, it will be used as a list of attributes for the element.

xml ( OBJECT )

Calling this method actually creates the XML document. That is to say, it fires all the handlers for the objects that have been built up and passed in. No XML will be output until this method has been called.

xmlns ( PREFIX, URI, CHILD )

This method inserts a new namespace into the resulting XML. PREFIX and URI are the namespace prefix and uri. CHILD is either an element object, or another namespace object.

xmlcdata ( TEXT, [ TEXT ] )

Inserts all arguments concatenated together inside a <![CDATA block.

xmldtd ( ELEMENT, SYSTEM [, PUBLIC ] )

Insert a DOCTYPE declaration into the resulting XML. You have to specify ELEMENT as the top level element name.

xmlcomment ( TEXT )

Inserts TEXT as an XML comment.

xmlpi ( TARGET, DATA )

Inserts TARGET and DATA as a processing instruction.

xmlprefix ( PREFIX )

Returns a new instance of XML::SAX::Builder, which will automatically prefix all element names with PREFIX. This can then be used in place of the original builder object where needed. The Handler will be copied from original builder object.

NB: It's still up to you to ensure that the prefix you're using is valid according to the current namespace scope! What that means: If you're thinking of using this function without calling xmlns() nearby, you'll lose.

TODO

Top

CDATA doesn't work at present, because XML::Filter::BufferText, which is used by XML::SAX::Writer, gets it wrong (inheritance & AUTOLOAD - always a bad mix :).

Having to specify the top level element name to the doctype is nasty, but I can't see an obvious way to automatically pick it up right now.

You can't have a tag called DESTROY.

SEE ALSO

Top

XML::SAX, XML::SAX::Writer.

Alternative XML document constructors: XML::SAX::Generator, XML::Writer.

AUTHOR

Top

Dominic Mitchell, <cpan@semantico.com>

COPYRIGHT AND LICENSE

Top

Copyright 2003 semantico

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

XML-SAX-Builder documentation Contained in the XML-SAX-Builder distribution. 
# @(#) $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__


# vim: set ai et sw=4 :