lib/Tree/Template/Declare.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

package Tree::Template::Declare; 
use strict;
use warnings;
use Sub::Exporter;
use Devel::Caller 'caller_args';
use Carp;
use Data::Dumper;
 
our $VERSION='0.1';
 
Sub::Exporter::setup_exporter({
    exports => [qw(tree node name attribs)],
    groups => {
        default => [qw(tree node name attribs)],
        builder => \&_set_builder_for_package,
    },
});
 
{
my %builder_for;
sub _set_builder_for_package {
    my ($class,$name,$args)=@_;
 
    my $builder_pkg=$args->{import_args}->[0]->[0];
 
    if (!ref($builder_pkg)) {
        if ($builder_pkg=~m{\A \+(\w+) \z}smx) {
            $builder_pkg="Tree::Template::Declare::$1";
        }
        eval "require $builder_pkg";
        croak "Can't load $builder_pkg: $@" if $@;
    }
    $builder_for{$args->{into}}=$builder_pkg;
 
    return 1;
}
 
sub builder_for {
    my ($pkg)=@_;
 
    if (exists $builder_for{$pkg}) {
        return $builder_for{$pkg};
    }
    else {
        return $pkg;
    }
}
}
 
our $current_node;
 
sub tree(&) {
    local $current_node=undef;
    my ($ret)=$_[0]->(caller_args(1));
    #warn "returning @{[ $ret->name ]}\n"; 
    return $ret;
}
 
sub node(&) {
    my $node=builder_for(caller)->new_node();
    #warn "new node\n"; 
    {
        local $current_node=$node;
        $_[0]->(caller_args(1));
    }
    if ($current_node) {
        #warn "adding to parent (@{[ $current_node->name ]})\n"; 
        builder_for(caller)->add_child_node($current_node,$node);
    }
    return $node;
}
 
sub name($) {
    #warn "setting name ($_[0])\n"; 
    builder_for(caller)->set_node_name($current_node,$_[0]);
}
 
sub attribs {
    my %attrs=@_;
    #warn "setting attributes\n"; 
    builder_for(caller)->set_node_attributes($current_node,\%attrs);
    return;
}
 
1;