diff options
| -rw-r--r-- | ChangeLog | 24 | ||||
| -rw-r--r-- | TODO | 4 | ||||
| -rw-r--r-- | lib/Tree/Template/Declare.pm | 299 | ||||
| -rw-r--r-- | lib/Tree/Template/Declare/DAG_Node.pm | 91 | ||||
| -rw-r--r-- | lib/Tree/Template/Declare/HTML_Element.pm | 111 | ||||
| -rw-r--r-- | lib/Tree/Template/Declare/LibXML.pm | 150 | ||||
| -rw-r--r-- | t/01-basic.t | 27 | ||||
| -rw-r--r-- | t/02-xslt.t | 67 | ||||
| -rw-r--r-- | t/03-html.t | 47 | ||||
| -rw-r--r-- | t/04-xml.t | 54 | ||||
| -rw-r--r-- | t/05-mixed.t | 55 | ||||
| -rw-r--r-- | t/06-code.t | 58 | ||||
| -rw-r--r-- | t/07-inherit.t | 67 | ||||
| -rw-r--r-- | xt/00-author-critic.t | 35 | ||||
| -rw-r--r-- | xt/00-author-minver.t | 33 | ||||
| -rw-r--r-- | xt/00-author-pod.t | 33 | ||||
| -rw-r--r-- | xt/perlcriticrc | 123 |
17 files changed, 1278 insertions, 0 deletions
diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..66c42e9 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,24 @@ +.. -*- mode: rst; coding: utf-8 -*- +0.6 2015-03-25 + - fixed tests that depended on a particular output from + Tree::DAG_Node::tree_to_lol(), they should now work with any + version of Tree::DAG_Node + +0.5 2013-01-27 + - fixed tests broken by better hash randomisation in perl 5.18 + +0.4 2011-02-13 + - fixed test for HTML::Element + - silenced some critic violations + +0.3 2009-06-27 + - now the "current node" is global, so that you can call + node-generating subs in other packages, and actually get the + result (see 07-inherit.t) + +0.2 2009-04-30 + - fixed Perl::Critic tests + - fixed perl version requirement + +0.1 2009-04-27 + - initial version @@ -0,0 +1,4 @@ +.. -*- mode: rst; coding: utf-8 -*- + +- make it use whatever tree class we want, via adapters +- try not to clobber ``@_`` *might work* 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 diff --git a/t/01-basic.t b/t/01-basic.t new file mode 100644 index 0000000..01d3510 --- /dev/null +++ b/t/01-basic.t @@ -0,0 +1,27 @@ +#!perl +use Test::Most tests => 2,'die'; +use strict; +use warnings; +use Tree::Template::Declare builder => '+DAG_Node'; + +my $tree=tree { + node { + name 'root'; + attribs name => 'none'; + node { + name 'coso1'; + attribs name => 'coso_1'; + attribs other => 'some'; + }; + node { + name 'coso2'; + }; + }; +}; + +cmp_deeply($tree->tree_to_lol(), + [[re(qr{coso1})],[re(qr{coso2})],re(qr{root})], + 'built the tree'); +is_deeply(($tree->daughters)[0]->attributes, + {name => 'coso_1', other => 'some'}, + 'attributes'); diff --git a/t/02-xslt.t b/t/02-xslt.t new file mode 100644 index 0000000..d36c132 --- /dev/null +++ b/t/02-xslt.t @@ -0,0 +1,67 @@ +#!perl +package main; +use Test::Most 'die'; +BEGIN { +eval 'use Tree::DAG_Node::XPath 0.10; require Tree::Transform::XSLTish'; +plan skip_all => 'Tree::DAG_Node::XPath 0.10 and Tree::Transform::XSLTish needed for this test' if $@; +} +plan tests => 3; + +package Copy;{ +use Tree::Transform::XSLTish; +use Tree::Template::Declare::DAG_Node; +use Tree::Template::Declare builder => Tree::Template::Declare::DAG_Node->new('Tree::DAG_Node::XPath'); +use strict; +use warnings; + +tree_rule match => '/', action => sub { + tree { + $_[0]->apply_rules; + }; +}; + +tree_rule match => '*', priority => 0, action => sub { + node { + name $_[0]->it->name; + attribs %{$_[0]->it->attributes}; + $_[0]->apply_rules; + }; +}; + +} + +package main; +use strict; +use warnings; +use Tree::Template::Declare builder => Tree::Template::Declare::DAG_Node->new('Tree::DAG_Node::XPath'); +use Data::Dumper; + +my $tree=tree { + node { + name 'root'; + attribs name => 'none'; + node { + name 'coso1'; + attribs name => 'coso_1'; + }; + node { + name 'coso2'; + node { + name 'coso3'; + }; + }; + }; +}; + +diag "transforming"; +my $trans=Copy->new(); +my ($tree2)=$trans->transform($tree); + +ok(defined $tree,'built'); +ok(defined $tree2,'transformed'); + +diag "comparing"; +is($tree->tree_to_lol_notation(), + $tree2->tree_to_lol_notation(), + 'tree copy'); + diff --git a/t/03-html.t b/t/03-html.t new file mode 100644 index 0000000..6c1348d --- /dev/null +++ b/t/03-html.t @@ -0,0 +1,47 @@ +#!perl +use Test::Most 'die'; +BEGIN { +eval 'use HTML::Element'; +plan skip_all => 'HTML::Element needed for this test' if $@; +} +plan tests => 1; +use strict; +use warnings; +use Tree::Template::Declare builder => '+HTML_Element'; +use Data::Dumper; + +my $tree=tree { + node { + name 'html'; + node { + name 'head'; + node { + name 'title'; + text_node 'Page title'; + } + }; + node { + name 'body'; + node { + name 'p'; + attribs id => 'p1'; + attribs class => 'para'; + text_node 'Page para'; + }; + }; + }; +}; + +my $expected_tree = HTML::Element->new_from_lol( + ['html', + ['head', + ['title','Page title'], + ], + ['body', + ['p','Page para',{class=>'para',id=>'p1'}], + ], + ], +); +ok($tree->same_as($expected_tree), + 'HTML tree' +); diff --git a/t/04-xml.t b/t/04-xml.t new file mode 100644 index 0000000..bd4ada3 --- /dev/null +++ b/t/04-xml.t @@ -0,0 +1,54 @@ +#!perl +use Test::Most 'die'; +BEGIN { +eval 'use XML::LibXML'; +plan skip_all => 'XML::LibXML needed for this test' if $@; +} +plan tests => 2; +use strict; +use warnings; +use Tree::Template::Declare builder => '+LibXML'; +use Data::Dumper; + +xmlns test => 'http://test/'; + +sub make_tree { + tree { + node { + name 'stuff'; + node { + name 'test:elem1'; + attribs 'test:buh' => 'testing'; + attribs id => 1; + node { + name 'test:sub1'; + text_node 'some content'; + } + }; + node { + name 'elem2'; + attribs id => 2; + }; + }; + }; +} + +{ +my $tree=make_tree(); + +is($tree->toStringC14N(0), + qq{<stuff><test:elem1 xmlns:test="http://test/" id="1" test:buh="testing"><test:sub1>some content</test:sub1></test:elem1><elem2 id="2"></elem2></stuff>}, + 'XML document without default NS' +); +} + +xmlns ':default' => 'ftp://test/'; + +{ +my $tree=make_tree(); + +is($tree->toStringC14N(0), + qq{<stuff xmlns="ftp://test/"><test:elem1 xmlns:test="http://test/" id="1" test:buh="testing"><test:sub1>some content</test:sub1></test:elem1><elem2 id="2"></elem2></stuff>}, + 'XML document with default NS' +); +} diff --git a/t/05-mixed.t b/t/05-mixed.t new file mode 100644 index 0000000..85bcf37 --- /dev/null +++ b/t/05-mixed.t @@ -0,0 +1,55 @@ +#!perl +use Test::Most 'die'; +BEGIN { +eval 'use XML::LibXML'; +plan skip_all => 'XML::LibXML needed for this test' if $@; +} +plan tests => 2; +use strict; +use warnings; +use Tree::Template::Declare -prefix=> 'x', builder => '+LibXML'; +use Tree::Template::Declare -prefix=> 'd', builder => '+DAG_Node'; + +use Data::Dumper; + +xxmlns test => 'http://test/'; + +my $xmltree= xtree { + xnode { + xname 'stuff'; + xnode { + xname 'test:elem1'; + xattribs id => 1, 'test:buh' => 'testing'; + xnode { + xname 'test:sub1'; + } + }; + xnode { + xname 'elem2'; + xattribs id => 2; + }; + }; +}; + +is($xmltree->toStringC14N(0), + qq{<stuff><test:elem1 xmlns:test="http://test/" id="1" test:buh="testing"><test:sub1></test:sub1></test:elem1><elem2 id="2"></elem2></stuff>}, + 'XML document' +); + +my $dagtree=dtree { + dnode { + dname 'root'; + dattribs name => 'none'; + dnode { + dname 'coso1'; + dattribs name => 'coso_1'; + }; + dnode { + dname 'coso2'; + }; + }; +}; + +cmp_deeply($dagtree->tree_to_lol(), + [[re(qr{coso1})],[re(qr{coso2})],re(qr{root})], + 'DAG_Node tree'); diff --git a/t/06-code.t b/t/06-code.t new file mode 100644 index 0000000..f80c7fa --- /dev/null +++ b/t/06-code.t @@ -0,0 +1,58 @@ +#!perl +use Test::Most tests => 2,'die'; +use strict; +use warnings; +use Tree::Template::Declare builder => '+DAG_Node'; +use Data::Dumper; + +sub make_item { + my ($name,$id)=@_; + + return detached node { + name 'item'; + attribs id => $id; + node { + name 'description'; + attribs name => $name; + }; + }; +} + +sub make_list { + my (@items)=@_; + + my @item_nodes=map {make_item(@$_)} @items; + + return node { + name 'list'; + attach_nodes @item_nodes; + }; +} + +my $tree=tree { + make_list([gino => 1], + [pino => 2], + [rino => 3], + ); +}; + +cmp_deeply($tree->tree_to_lol(), + [ + [[re(qr{description})],re(qr{item})], + [[re(qr{description})],re(qr{item})], + [[re(qr{description})],re(qr{item})], + re(qr{list})], + 'tree with code'); + +my @attrs; +$tree->walk_down({callback=>sub{ + push @attrs,$_[0]->attributes; + 1 + }}); +is_deeply(\@attrs, + [{}, + {id=>1},{name=>'gino'}, + {id=>2},{name=>'pino'}, + {id=>3},{name=>'rino'}, + ], + 'attributes'); diff --git a/t/07-inherit.t b/t/07-inherit.t new file mode 100644 index 0000000..642b24f --- /dev/null +++ b/t/07-inherit.t @@ -0,0 +1,67 @@ +#!perl +package Base;{ +use strict; +use warnings; +use Tree::Template::Declare builder => '+DAG_Node'; + +sub doc { + my ($self)=@_; + tree { + node { + name 'doc'; + $self->head(); + $self->body(); + } + } +} + +sub head { + node { name 'title' }; +} + +sub body { + node { + name 'content'; + $_[0]->content(); + } +} + +sub content { + node { name 'stuff' } +} + +} + +package Derived;{ +use strict; +use warnings; +use Tree::Template::Declare builder => '+DAG_Node'; +use base 'Base'; + +sub head { + node { name 'whatever' }; + $_[0]->SUPER::head(); +} + +sub content { + node { name 'something' } +} + +} + +package main; +use Test::Most tests=>2,'die'; +use strict; +use warnings; + +my $base_tree=Base->doc(); + +cmp_deeply($base_tree->tree_to_lol(), + [[re(qr{title})],[[re(qr{stuff})],re(qr{content})],re(qr{doc})], + 'base tree'); + +my $deriv_tree=Derived->doc(); + +cmp_deeply($deriv_tree->tree_to_lol(), + [[re(qr{whatever})],[re(qr{title})],[[re(qr{something})],re(qr{content})],re(qr{doc})], + 'derived tree'); diff --git a/xt/00-author-critic.t b/xt/00-author-critic.t new file mode 100644 index 0000000..13fe8e7 --- /dev/null +++ b/xt/00-author-critic.t @@ -0,0 +1,35 @@ +#!/usr/bin/perl + +# Test that the module passes perlcritic +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +my @MODULES = ( + 'Perl::Critic 1.098', + 'Test::Perl::Critic 1.01', + 'File::Spec', +); + +# Don't run tests during end-user installs +use Test::More; +unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { + plan( skip_all => "Author tests not required for installation" ); +} + +# Load the testing modules +foreach my $MODULE ( @MODULES ) { + eval "use $MODULE"; + if ( $@ ) { + $ENV{RELEASE_TESTING} + ? die( "Failed to load required release-testing module $MODULE" ) + : plan( skip_all => "$MODULE not available for testing" ); + } +} +my $rcfile = File::Spec->catfile( 'xt', 'perlcriticrc' ); +Test::Perl::Critic->import( -profile => $rcfile ); +all_critic_ok(); + +1; diff --git a/xt/00-author-minver.t b/xt/00-author-minver.t new file mode 100644 index 0000000..4dfb876 --- /dev/null +++ b/xt/00-author-minver.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl + +# Test that our declared minimum Perl version matches our syntax +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +my @MODULES = ( + 'Perl::MinimumVersion 1.20', + 'Test::MinimumVersion 0.008', +); + +# Don't run tests during end-user installs +use Test::More; +unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { + plan( skip_all => "Author tests not required for installation" ); +} + +# Load the testing modules +foreach my $MODULE ( @MODULES ) { + eval "use $MODULE"; + if ( $@ ) { + $ENV{RELEASE_TESTING} + ? die( "Failed to load required release-testing module $MODULE" ) + : plan( skip_all => "$MODULE not available for testing" ); + } +} + +all_minimum_version_from_metayml_ok(); + +1; diff --git a/xt/00-author-pod.t b/xt/00-author-pod.t new file mode 100644 index 0000000..2cdfcc4 --- /dev/null +++ b/xt/00-author-pod.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl + +# Test that the syntax of our POD documentation is valid +use strict; +BEGIN { + $| = 1; + $^W = 1; +} + +my @MODULES = ( + 'Pod::Simple 3.07', + 'Test::Pod 1.26', +); + +# Don't run tests during end-user installs +use Test::More; +unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { + plan( skip_all => "Author tests not required for installation" ); +} + +# Load the testing modules +foreach my $MODULE ( @MODULES ) { + eval "use $MODULE"; + if ( $@ ) { + $ENV{RELEASE_TESTING} + ? die( "Failed to load required release-testing module $MODULE" ) + : plan( skip_all => "$MODULE not available for testing" ); + } +} + +all_pod_files_ok(); + +1; diff --git a/xt/perlcriticrc b/xt/perlcriticrc new file mode 100644 index 0000000..029461c --- /dev/null +++ b/xt/perlcriticrc @@ -0,0 +1,123 @@ +severity = 1 +color = 1 +only = 1 + +[BuiltinFunctions::ProhibitBooleanGrep] +[BuiltinFunctions::ProhibitComplexMappings] +[BuiltinFunctions::ProhibitLvalueSubstr] +[BuiltinFunctions::ProhibitReverseSortBlock] +[BuiltinFunctions::ProhibitSleepViaSelect] +[BuiltinFunctions::ProhibitStringyEval] +[BuiltinFunctions::ProhibitStringySplit] +[BuiltinFunctions::ProhibitUniversalCan] +[BuiltinFunctions::ProhibitUniversalIsa] +[BuiltinFunctions::ProhibitVoidGrep] +[BuiltinFunctions::ProhibitVoidMap] +[BuiltinFunctions::RequireBlockGrep] +[BuiltinFunctions::RequireBlockMap] +[BuiltinFunctions::RequireGlobFunction] +[BuiltinFunctions::RequireSimpleSortBlock] +[ClassHierarchies::ProhibitAutoloading] +[ClassHierarchies::ProhibitExplicitISA] +[ClassHierarchies::ProhibitOneArgBless] +[CodeLayout::ProhibitHardTabs] +[CodeLayout::ProhibitParensWithBuiltins] +[CodeLayout::ProhibitQuotedWordLists] +[CodeLayout::ProhibitTrailingWhitespace] +[CodeLayout::RequireConsistentNewlines] +[CodeLayout::RequireTrailingCommas] +[ControlStructures::ProhibitCStyleForLoops] +[ControlStructures::ProhibitCascadingIfElse] +[ControlStructures::ProhibitDeepNests] +[ControlStructures::ProhibitLabelsWithSpecialBlockNames] +[ControlStructures::ProhibitMutatingListFunctions] +[ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions] +[ControlStructures::ProhibitPostfixControls] +[ControlStructures::ProhibitUnlessBlocks] +[ControlStructures::ProhibitUnreachableCode] +[ControlStructures::ProhibitUntilBlocks] +[Documentation::RequirePackageMatchesPodName] +[Documentation::RequirePodAtEnd] +[ErrorHandling::RequireCarping] +[ErrorHandling::RequireCheckingReturnValueOfEval] +[InputOutput::ProhibitBacktickOperators] +[InputOutput::ProhibitBarewordFileHandles] +[InputOutput::ProhibitExplicitStdin] +[InputOutput::ProhibitInteractiveTest] +[InputOutput::ProhibitJoinedReadline] +[InputOutput::ProhibitOneArgSelect] +[InputOutput::ProhibitReadlineInForLoop] +[InputOutput::ProhibitTwoArgOpen] +[InputOutput::RequireBracedFileHandleWithPrint] +[InputOutput::RequireBriefOpen] +[InputOutput::RequireCheckedClose] +[InputOutput::RequireCheckedOpen] +[InputOutput::RequireCheckedSyscalls] +[Miscellanea::ProhibitFormats] +[Miscellanea::ProhibitTies] +[Miscellanea::ProhibitUnrestrictedNoCritic] +[Miscellanea::ProhibitUselessNoCritic] +[Modules::ProhibitAutomaticExportation] +[Modules::ProhibitExcessMainComplexity] +[Modules::ProhibitMultiplePackages] +[Modules::RequireBarewordIncludes] +[Modules::RequireEndWithOne] +[Modules::RequireExplicitPackage] +[Modules::RequireFilenameMatchesPackage] +[Modules::RequireNoMatchVarsWithUseEnglish] +[Modules::RequireVersionVar] +[NamingConventions::Capitalization] +[NamingConventions::ProhibitAmbiguousNames] +[References::ProhibitDoubleSigils] +[RegularExpressions::ProhibitCaptureWithoutTest] +[RegularExpressions::ProhibitFixedStringMatches] +[RegularExpressions::ProhibitUnusualDelimiters] +[RegularExpressions::RequireBracesForMultiline] +[RegularExpressions::RequireDotMatchAnything] +[RegularExpressions::RequireExtendedFormatting] +[RegularExpressions::RequireLineBoundaryMatching] +[Subroutines::ProhibitAmpersandSigils] +[Subroutines::ProhibitBuiltinHomonyms] +[Subroutines::ProhibitExcessComplexity] +[Subroutines::ProhibitExplicitReturnUndef] +[Subroutines::ProhibitManyArgs] +[Subroutines::ProhibitNestedSubs] +[Subroutines::ProhibitReturnSort] +[Subroutines::ProhibitSubroutinePrototypes] +[Subroutines::ProtectPrivateSubs] +[Subroutines::RequireFinalReturn] +[TestingAndDebugging::ProhibitNoStrict] +[TestingAndDebugging::ProhibitNoWarnings] +[TestingAndDebugging::ProhibitProlongedStrictureOverride] +[TestingAndDebugging::RequireTestLabels] +[TestingAndDebugging::RequireUseStrict] +[TestingAndDebugging::RequireUseWarnings] +[ValuesAndExpressions::ProhibitCommaSeparatedStatements] +[ValuesAndExpressions::ProhibitConstantPragma] +[ValuesAndExpressions::ProhibitEscapedCharacters] +[ValuesAndExpressions::ProhibitImplicitNewlines] +[ValuesAndExpressions::ProhibitInterpolationOfLiterals] +[ValuesAndExpressions::ProhibitLeadingZeros] +[ValuesAndExpressions::ProhibitLongChainsOfMethodCalls] +[ValuesAndExpressions::ProhibitMagicNumbers] +[ValuesAndExpressions::ProhibitMismatchedOperators] +[ValuesAndExpressions::ProhibitMixedBooleanOperators] +[ValuesAndExpressions::ProhibitNoisyQuotes] +[ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters] +[ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator] +[ValuesAndExpressions::ProhibitVersionStrings] +[ValuesAndExpressions::RequireInterpolationOfMetachars] +[ValuesAndExpressions::RequireNumberSeparators] +[ValuesAndExpressions::RequireQuotedHeredocTerminator] +[ValuesAndExpressions::RequireUpperCaseHeredocTerminator] +[Variables::ProhibitConditionalDeclarations] +[Variables::ProhibitMatchVars] +[Variables::ProhibitPerl4PackageNames] +[Variables::ProhibitPunctuationVars] +[Variables::ProhibitReusedNames] +[Variables::ProhibitUnusedVariables] +[Variables::ProtectPrivateVars] +[Variables::RequireInitializationForLocalVars] +[Variables::RequireLexicalLoopIterators] +[Variables::RequireLocalizedPunctuationVars] +[Variables::RequireNegativeIndices] |