File Coverage

blib/lib/XML/LibXML/LazyBuilder.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package XML::LibXML::LazyBuilder;

use 5.008000;
use strict;
use warnings FATAL => 'all';

use Carp         ();
use Scalar::Util ();
use XML::LibXML  ();

# consider using Exporter::Lite - djt
require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use XML::LibXML::LazyBuilder ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	DOM E P C D F DTD
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
);

our $VERSION = '0.08';

# This is a map of all the DOM level 3 node names for
# non-element/attribute nodes. Note how there is no provision for
# processing instructions.
my %NODES = (
    '#cdata-section'     => 1,
    '#comment'           => 1,
    '#document'          => 1,
    '#document-fragment' => 1,
    '#text'              => 1,
);

# Note this is and will remain a stub until appropriate behaviour can
# be worked out.

# (Perhaps a name of ?foo for processing instructions?)

# nah, special methods for non-element nodes!



# Preloaded methods go here.


# This predicate is an alternative to using UNIVERSAL::isa as a
# function (which is a no-no); it will return true if a blessed
# reference is derived from a built-in reference type.

sub _is_really {
    my ($obj, $type) = @_;
    return unless defined $obj and ref $obj;
    return Scalar::Util::blessed($obj) ? $obj->isa($type) : ref $obj eq $type;
}

sub DOM ($;$$) {
    my ($sub, $ver, $enc) = @_;

    my $dom = XML::LibXML::Document->new ($ver || "1.0", $enc || "utf-8");

    # this whole $dom $sub thing is cracking me up ;) -- djt
    my $node = $sub->($dom);

    if (_is_really($node, 'XML::LibXML::DocumentFragment')) {
        # "Appending a document fragment node to a document node not
        # supported yet!", says XML::LibXML, so we work around it.

        for my $child ($node->childNodes) {
            #warn $child->ownerDocument;
            $child->unbindNode;
            if ($child->nodeType == 1) {
                if (my $root = $dom->documentElement) {
                    unless ($root->isSameNode($child)) {
                        Carp::croak("Trying to insert a second root element");
                    }
                }
                else {
                    $dom->setDocumentElement($child);
                }
            }
            else {
                $dom->appendChild($child);
            }
        }
    }
    elsif (_is_really($node, 'XML::LibXML::Element')) {
        # NO-OP: Elements get attached to the root from inside the E
        # function so it can access the namespace map.
    }
    else {
        $dom->appendChild($node);
    }

    $dom;
}

sub E ($;$@) {
    my ($name, $attr, @contents) = @_;

    return sub {
        my ($dom, $parent) = @_;

        # note, explicit namespace declarations in the attribute set
        # are held separately from actual namespace mappings found
        # from scanning the document.
        my (%ns, %nsdecl, %attr, $elem, $prefix);

        # pull the namespace declarations out of the attribute set
        if (_is_really($attr, 'HASH')) {
            while (my ($n, $v) = each %$attr) {
                if ($n =~ /^xmlns(?::(.*))?$/) {
                    $nsdecl{$1 || ''} = $v;
                }
                else {
                    $attr{$n} = $v;
                }
            }
        }

        if (_is_really($name, 'XML::LibXML::Element')) {
            # throw an exception if the element is not bound to a
            # document, which itself should become our new $dom
            Carp::croak("The supplied element must be bound to a document")
                  unless $dom = $name->ownerDocument;

            # and of course $name is our new $elem
            $elem   = $name;
            $name   = $elem->nodeName;
            $prefix = $elem->prefix || '';

            # then we don't need to scan the document for namespaces,
            # but we probably should set it for attributes
            %ns = map { $elem->lookupNamespacePrefix($_) || '' => $_ }
                $elem->getNamespaces;
        }
        elsif (my $huh = ref $name) {
            Carp::croak("Expected an XML::LibXML::Element; got $huh instead");
        }
        else {
            # $name is a string
            ($prefix) = ($name =~ /^(?:([^:]+):)?(.*)$/);
            $prefix ||= '';

            # XXX what happens if $name isn't a valid QName?

            $elem = $dom->createElement($name);

            # check for a document element so we can find existing namespaces
            if ($parent ||= $dom->documentElement) {
                # XXX this is naive
                for my $node ($parent->findnodes('namespace::*')) {
                    $ns{$node->declaredPrefix || ''} = $node->declaredURI;
                }
            }
            else {
                # do this here to make the tree walkable
                $dom->setDocumentElement($elem);
            }

        }

        # now do namespaces, overriding if necessary

        # first with the implicit mapping
        if ($ns{$prefix}) {
            $elem->setNamespace($ns{$prefix}, $prefix, 1);
        }

        # then with the explicit declarations
        for my $k (keys %nsdecl) {
            # activate if the ns matches the prefix
            $elem->setNamespace($nsdecl{$k}, $k, $k eq $prefix);
        }

        # now smoosh the mappings together for the attributes
        %ns = (%ns, %nsdecl);

        # NOW do the attributes
        while (my ($n, $v) = each %attr) {
            my ($pre, $loc) = ($n =~ /^(?:([^:]+):)?(.*)$/);

            # it'll probably mess up xpath queries if we explicitly
            # add namespaces to non-prefixed attributes
            if ($pre and my $nsuri = $ns{$pre}) {
                $elem->setAttributeNS($nsuri, $n, $v);
            }
            else {
                $elem->setAttribute($n, $v);
            }
        }

        # and finally child nodes
        for my $child (@contents) {
            if (_is_really($child, 'CODE')) {
                $elem->appendChild ($child->($dom, $elem));
            }
            elsif (_is_really($child, 'XML::LibXML::Node')) {
                # hey, why not?
                $elem->appendChild($child);
            }
            elsif (my $huh = ref $child) {
                Carp::croak
                      ("$huh is neither a CODE ref or an XML::LibXML::Node");
            }
            else {
                $elem->appendTextNode ($child);
            }
        }

        $elem;
    };
}

# processing instruction
sub P ($;$@) {
    my ($target, $attr, @text) = @_;

    return sub {
        my $dom = shift;

        # copy, otherwise this will just keep packing it on if executed
        # more than once
        my @t = @text;

        # turn into k="v" convention
        if (defined $attr) {
            if (_is_really($attr, 'HASH')) {
                my $x = join ' ',
                    map { sprintf '%s="%s"', $_, $attr->{$_} } keys %$attr;
                unshift @t, $x;
            }
            else {
                unshift @t, $attr;
            }
        }

        return $dom->createProcessingInstruction($target, join '', @t);
    };
}

# comment
sub C (;@) {
    my @text = @_;

    return sub {
        my $dom = shift;
        $dom->createComment(join '', @text);
    };
}

# CDATA
sub D (;@) {
    my @text = @_;

    return sub {
        my $dom = shift;
        $dom->createCDATASection(join '', @text);
    };
}

# document fragment
sub F (@) {
    my @children = @_;

    return sub {
        my $dom = shift;
        my $frag = $dom->createDocumentFragment;
        for my $child (@children) {
            # same as E
            if (_is_really($child, 'CODE')) {
                $frag->appendChild($child->($dom));
            }
            elsif (_is_really($child, 'XML::LibXML::Node')) {
                $frag->appendChild($child);
            }
            elsif (my $huh = ref $child) {
                Carp::croak
                      ("$huh is neither a CODE ref or an XML::LibXML::Node");
            }
            else {
                $frag->appendChild($dom->createTextNode($child));
            }
        }
        $frag;
    };
}

sub DTD ($;$$) {
    my ($name, $public, $system) = @_;

    return sub {
        my $dom = shift;

        # must be an XS hiccup; can't just pass these in if they're undef
        $dom->createExternalSubset($name, $public || undef, $system || undef);
    };
}

1;
__END__