lib/Tree/Template/Declare/LibXML.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143

package Tree::Template::Declare::LibXML; 
 
use strict;
use warnings;
use Carp;
use XML::LibXML;
 
sub new {
    my ($class)=@_;
 
    return bless {ns=>{':default'=>undef}},$class;
}
 
sub _munge_exports {
    my ($self,$exports,$current_node_aref)=@_;
 
    my %all_exports=(
        %{$exports},
        xmlns => sub($$) {
            $self->{ns}->{$_[0]}=$_[1];
            return;
        },
        text_node => sub($) {
            if ($current_node_aref->[0]) {
                $current_node_aref->[0]->appendTextNode($_[0]);
            }
        },
    );
 
    return \%all_exports;
}
 
sub new_tree {
    my ($self)=@_;
 
    return XML::LibXML::Document->new();
}
 
sub finalize_tree {
    my ($self,$tree)=@_;
 
    return $tree;
}
 
sub _get_ns {
    my ($self,$name)=@_;
 
    my ($prefix)=($name=~m{\A (.*?) : }smx);
 
    if (!defined($prefix) || length($prefix)==0) {
        return '',$self->{ns}->{':default'};
    }
 
    if (exists $self->{ns}->{$prefix}) {
        return $prefix, $self->{ns}->{$prefix};
    }
    return;
}
 
sub new_node {
    my ($self)=@_;
 
    return XML::LibXML::Element->new('');
}
 
sub add_child_node {
    my ($self,$parent,$child)=@_;
 
    my $doc=$parent->ownerDocument;
    if ($doc) {
        $child=$doc->adoptNode($child);
    }
 
    if ($parent->isa('XML::LibXML::Document')) {
        $parent->setDocumentElement($child);
    }
    else {
        $parent->appendChild($child);
    }
    return $parent;
}
 
sub set_node_name {
    my ($self,$node,$name)=@_;
 
    $node->setNodeName($name);
    my ($prefix,$uri)=$self->_get_ns($name);
    if ($uri) {
        $node->setNamespace($uri,$prefix,1);
    }
 
    return;
}
 
sub set_node_attributes {
    my ($self,$node,$attrs)=@_;
 
    while (my ($name,$val)=each %{$attrs}) {
        my ($prefix,$uri)=$self->_get_ns($name);
        if ($prefix and $uri) {
            $node->setAttributeNS($uri, $name, $val);
        }
        else {
            $node->setAttribute($name, $val);
        }
    }
 
    return;
}
 
1;
__END__
 
# ABSTRACT: adaptor for LibXML 
 
=head1 SYNOPSIS
 
See L<Tree::Template::Declare>.
 
=head1 SPECIFICITIES
 
A function C<xmlns> is exported, so that you can declare XML namespaces:
 
  xmlns test => 'http://test/';
 
  node { name 'test:elem'; attribs id => 1, 'test:attr' => 5 };
 
You I<can> create nodes with qualified names with undeclared prefixes,
but it's probably not a good idea.
 
To add text nodes, you could do something like:
 
  my $el=node { name 'elem_with_text' };
  $el->appendTextNode('some text content');
 
This is ugly, so you can do:
 
 node {
   name 'elem_with_text';
   text_node 'some text content';
 };
 
=cut