summaryrefslogtreecommitdiff
path: root/lib/Tree/Template
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Tree/Template')
-rw-r--r--lib/Tree/Template/Declare.pm299
-rw-r--r--lib/Tree/Template/Declare/DAG_Node.pm91
-rw-r--r--lib/Tree/Template/Declare/HTML_Element.pm111
-rw-r--r--lib/Tree/Template/Declare/LibXML.pm150
4 files changed, 651 insertions, 0 deletions
diff --git a/lib/Tree/Template/Declare.pm b/lib/Tree/Template/Declare.pm
new file mode 100644
index 0000000..cf0817c
--- /dev/null
+++ b/lib/Tree/Template/Declare.pm
@@ -0,0 +1,299 @@
+package Tree::Template::Declare;
+use strict;
+use warnings;
+use Sub::Exporter;
+use Devel::Caller 'caller_args';
+use Carp;
+use Data::Dumper;
+use 5.006;
+
+our $VERSION='0.6';
+
+{
+my $exporter=Sub::Exporter::build_exporter({
+ groups => {
+ default => \&_build_group,
+ },
+});
+
+sub import {
+ my ($pack,@rest)=@_;
+
+ if (@rest) {
+ @_=($pack,-default => {@rest});
+ }
+ goto $exporter;
+}
+}
+
+our @nodes_stack;
+
+sub _build_group {
+ my ($class,$name,$args,$coll)=@_;
+
+ my $builder=$args->{builder};
+
+ if (! ref $builder) {
+ my $builder_pkg=$builder;
+ if ($builder_pkg=~m{\A [+](\w+) \z}smx) {
+ $builder_pkg="Tree::Template::Declare::$1";
+ }
+ eval "require $builder_pkg" ## no critic (ProhibitStringyEval)
+ or croak "Can't load $builder_pkg: $@"; ## no critic (ProhibitPunctuationVars)
+
+ if ($builder_pkg->can('new')) {
+ $builder=$builder_pkg->new();
+ }
+ else {
+ $builder=$builder_pkg;
+ }
+ }
+
+ my $normal_exports= {
+ tree => sub(&) {
+ my $tree=$builder->new_tree();
+
+ unshift @nodes_stack,$tree;
+ $_[0]->(caller_args(1));
+ shift @nodes_stack;
+
+ return $builder->finalize_tree($tree);
+ },
+ node => sub (&) {
+ my $node=$builder->new_node();
+
+ unshift @nodes_stack, $node;
+ $_[0]->(caller_args(1));
+ shift @nodes_stack;
+
+ my $scalar_context=defined wantarray && !wantarray;
+ if (@nodes_stack && !$scalar_context) {
+ $builder->add_child_node($nodes_stack[0],$node);
+ }
+ return $node;
+ },
+ attach_nodes => sub {
+ if (@nodes_stack) {
+ for my $newnode (@_) {
+ $builder->add_child_node($nodes_stack[0],
+ $newnode);
+ }
+ }
+ },
+ name => sub ($) {
+ $builder->set_node_name($nodes_stack[0],$_[0]);
+ return;
+ },
+ attribs => sub {
+ my %attrs=@_;
+ $builder->set_node_attributes($nodes_stack[0],\%attrs);
+ return;
+ },
+ detached => sub($) { return scalar $_[0] },
+ };
+ if ($builder->can('_munge_exports')) {
+ return $builder->_munge_exports($normal_exports,\@nodes_stack);
+ }
+ else {
+ return $normal_exports;
+ }
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Tree::Template::Declare - easily build tree structures
+
+=head1 SYNOPSIS
+
+ use Tree::Template::Declare builder => '+DAG_Node';
+
+ my $tree=tree {
+ node {
+ name 'root';
+ attribs name => 'none';
+ node {
+ name 'first';
+ attribs name => 'number_1';
+ attribs other => 'some';
+ };
+ node {
+ name 'second';
+ };
+ };
+ };
+
+=head1 FUNCTIONS
+
+For details on the implementation of these functions, see the
+L</BUILDER> section, and the documentation of your chosen builder.
+
+=head2 C<tree>
+
+This function takes a code ref or a block, inside which calls to
+C<node> should be made, and returns a properly constructed tree
+containing those nodes.
+
+Uses the builder's C<new_tree> and C<finalize_tree>.
+
+=head2 C<node>
+
+This function takes a code ref or a block, inside which calls to
+C<name>, C<attribs>, and C<node> should be made, and returns the node.
+
+If I<not> called in scalar context, it also adds the node to the
+"calling" node or tree.
+
+Uses the builder's C<new_node> and C<add_child_node>.
+
+=head2 C<detached>
+
+Alias for C<scalar>, so that you can say C<return detached node ...>
+without having to worry about the calling context.
+
+=head2 C<attach_nodes>
+
+This function takes a list of nodes, and adds them (in order) to the
+"calling" node or tree. You should only use this with nodes you
+obtained by calling C<node> in scalar context.
+
+Uses the builder's C<add_child_node>.
+
+=head2 C<name>
+
+This function takes a scalar, and sets the name of the current node to
+the value of that scalar.
+
+Uses the builder's C<set_node_name>.
+
+=head2 C<attribs>
+
+This function takes a hash (not a hash ref), and sets the attributes
+of the current node.
+
+Uses the builder's C<set_node_attributes>.
+
+=head1 BUILDER
+
+To actually create nodes and trees, this module uses helper classes
+called "builders". You must always specify a builder package, class or
+object with the C<builder> option in the C<use> line.
+
+If the builder is an object, the methods discussed below will be
+called on it; if it's a class (i.e. a package that has a C<new>
+function), they will be called on an instance created by calling
+C<new> without parameters; otherwise they will be called as class
+methods.
+
+The builder must implement these methods:
+
+=over
+
+=item C<new_tree>
+
+ $tree = $current_node = $builder->new_tree();
+
+returns a tree object; that object will be set as the current node
+within the code passed to the C<tree> function
+
+=item C<finalize_tree>
+
+ return $builder->finalize_tree($tree);
+
+this function will be passed the object returned by C<new_tree>, after
+the code passed to C<tree> has been executed; the result of
+C<finalize_tree> will be the result of C<tree>
+
+=item C<new_node>
+
+ $current_node=$builder->new_node();
+
+returns a new, unattached node
+
+=item C<set_node_name>
+
+ $builder->set_node_name($current_node, $name);
+
+sets the name of the node (e.g. for SGML-like trees, this is the "tag
+name")
+
+=item C<set_node_attributes>
+
+ $builder->set_node_attributes($current_node, \%attribs);
+
+sets attributes of the node; it should not remove previously-set attributes
+
+=item C<add_child_node>
+
+ $builder->add_child_node($parent_node, $child_node);
+
+adds the second node at the end of the children list of the first node
+
+=back
+
+The builder can also implement an C<_munge_exports> method. If it
+does, C<_munge_exports> will be called with:
+
+=over 4
+
+=item *
+
+a hash ref consisting of the functions that C<Tree::Template::Declare>
+wants to export,
+
+=item *
+
+an array ref, whose first element will be the current node whenever
+the user calls an exported function
+
+=back
+
+C<_munge_exports> should return a hash ref with the functions that
+will actually be exported.
+
+See L<Sub::Exporter>, in particular the section on group builders, for
+details. See L<Tree::Template::Declare::HTML_Element> and
+L<Tree::Template::Declare::LibXML> for examples.
+
+=head1 IMPORTING
+
+This module uses L<Sub::Exporter>, although it munges the C<use> list
+before passing it to L<Sub::Exporter>. A line like:
+
+ use Tree::Template::Declare @something;
+
+becomes a call to L<Sub::Exporter>'s export sub like:
+
+ $export->('Tree::Template::Declare',-default => {@something});
+
+See L<Sub::Exporter>'s documentation for things like renaming the
+imports.
+
+You can C<use> this module more than once, with different builders and
+different names for the imports:
+
+ use Tree::Template::Declare -prefix=> 'x', builder => '+LibXML';
+ use Tree::Template::Declare -prefix=> 'd', builder => '+DAG_Node';
+
+=head1 KNOWN ISSUES & BUGS
+
+=over 4
+
+=item *
+
+C<_munge_exports> is ugly
+
+=item *
+
+the context-sensitivity of C<node> might not be the best way to DWIM
+for the creation of detached nodes
+
+=back
+
+=head1 AUTHOR
+
+Gianni Ceccarelli <dakkar@thenautilus.net>
+
+=cut
diff --git a/lib/Tree/Template/Declare/DAG_Node.pm b/lib/Tree/Template/Declare/DAG_Node.pm
new file mode 100644
index 0000000..6c7d700
--- /dev/null
+++ b/lib/Tree/Template/Declare/DAG_Node.pm
@@ -0,0 +1,91 @@
+package Tree::Template::Declare::DAG_Node;
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION='0.6';
+
+sub new {
+ my ($class,$node_class)=@_;
+ $node_class||='Tree::DAG_Node';
+
+ eval "require $node_class" or ## no critic (ProhibitStringyEval)
+ croak "Can't load $node_class: $@"; ## no critic (ProhibitPunctuationVars)
+
+ return bless {nc=>$node_class},$class;
+}
+
+sub new_tree {
+ my ($self)=@_;
+
+ return bless [],'Tree::Template::Declare::DAG_Node::Tree';
+}
+
+sub finalize_tree {
+ my ($self,$tree)=@_;
+
+ return $tree->[0];
+}
+
+sub new_node {
+ my ($self)=@_;
+
+ return $self->{nc}->new();
+}
+
+sub add_child_node {
+ my ($self,$parent,$child)=@_;
+
+ if ($parent->isa('Tree::Template::Declare::DAG_Node::Tree')) {
+ push @{$parent},$child;
+ return $parent;
+ }
+ return $parent->add_daughter($child);
+}
+
+sub set_node_name {
+ my ($self,$node,$name)=@_;
+
+ return $node->name($name);
+}
+
+sub set_node_attributes {
+ my ($self,$node,$attrs)=@_;
+
+ my %all_attributes=(
+ %{$node->attributes},
+ %{$attrs},
+ );
+
+ return $node->attributes(\%all_attributes);
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Tree::Template::Declare::DAG_Node
+
+=head1 SYNOPSIS
+
+See L<Tree::Template::Declare>.
+
+=head1 SPECIFICITIES
+
+This module will build trees using L<Tree::DAG_Node>. You can make it
+use another module (assuming it has the same interface, for example
+L<Tree::DAG_Node::XPath>) by passing the class name to the C<new>
+method.
+
+ use Tree::Template::Declare builder => '+DAG_Node'; # default
+
+ use Tree::Template::Declare builder =>
+ Tree::Template::Declare::DAG_Node->new('Tree::DAG_Node::XPath');
+ # custom class
+
+=head1 AUTHOR
+
+Gianni Ceccarelli <dakkar@thenautilus.net>
+
+=cut
diff --git a/lib/Tree/Template/Declare/HTML_Element.pm b/lib/Tree/Template/Declare/HTML_Element.pm
new file mode 100644
index 0000000..f8bdb90
--- /dev/null
+++ b/lib/Tree/Template/Declare/HTML_Element.pm
@@ -0,0 +1,111 @@
+package Tree::Template::Declare::HTML_Element;
+use strict;
+use warnings;
+use Carp;
+use HTML::Element;
+
+our $VERSION='0.6';
+
+sub new {
+ my ($class)=@_;
+
+ return bless {},$class;
+}
+
+sub _munge_exports {
+ my ($self,$exports)=@_;
+
+ my %all_exports=(
+ %{$exports},
+ text_node => sub($) {
+ $exports->{node}->(
+ sub {
+ $exports->{name}->('~text');
+ $exports->{attribs}->(text => $_[0]);
+ });
+ },
+ );
+
+ return \%all_exports;
+}
+
+sub new_tree {
+ my ($self)=@_;
+
+ return bless [],'Tree::Template::Declare::HTML_Element::Tree';
+}
+
+sub finalize_tree {
+ my ($self,$tree)=@_;
+
+ my $dom=$tree->[0];
+ $dom->deobjectify_text();
+ return $dom;
+}
+
+sub new_node {
+ my ($self)=@_;
+
+ return HTML::Element->new('~comment');
+}
+
+sub add_child_node {
+ my ($self,$parent,$child)=@_;
+
+
+ if ($parent->isa('Tree::Template::Declare::HTML_Element::Tree')) {
+ push @{$parent},$child;
+ return $parent;
+ }
+ return $parent->push_content($child);
+}
+
+sub set_node_name {
+ my ($self,$node,$name)=@_;
+
+ return $node->tag($name);
+}
+
+sub set_node_attributes {
+ my ($self,$node,$attrs)=@_;
+
+ while (my ($name,$val)=each %{$attrs}) {
+ $node->attr($name, $val);
+ }
+ return;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Tree::Template::Declare::HTML_Element
+
+=head1 SYNOPSIS
+
+See L<Tree::Template::Declare>.
+
+=head1 SPECIFICITIES
+
+This module will build trees using L<HTML::Element>.
+
+To create text nodes, you would be forced to say:
+
+ node {
+ name '~text';
+ attribs text => 'some text';
+ }
+
+which is too cumbersone. You can instead use:
+
+ text_node 'some text';
+
+HTML::Element's C<deobjectify_text> method will be called by
+C<finalize_tree> before returning the tree object.
+
+=head1 AUTHOR
+
+Gianni Ceccarelli <dakkar@thenautilus.net>
+
+=cut
diff --git a/lib/Tree/Template/Declare/LibXML.pm b/lib/Tree/Template/Declare/LibXML.pm
new file mode 100644
index 0000000..246ab8d
--- /dev/null
+++ b/lib/Tree/Template/Declare/LibXML.pm
@@ -0,0 +1,150 @@
+package Tree::Template::Declare::LibXML;
+use strict;
+use warnings;
+use Carp;
+use XML::LibXML;
+
+our $VERSION='0.6';
+
+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__
+
+=head1 NAME
+
+Tree::Template::Declare::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';
+ };
+
+=head1 AUTHOR
+
+Gianni Ceccarelli <dakkar@thenautilus.net>
+
+=cut
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-02 05:26:17 +0000