File Coverage

blib/lib/VS/RuleEngine/Writer/XML.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             package VS::RuleEngine::Writer::XML;
2              
3 10     10   821147 use strict;
  10         26  
  10         429  
4 10     10   59 use warnings;
  10         20  
  10         369  
5              
6 10     10   52 use Carp qw(croak);
  10         24  
  10         557  
7 10     10   85 use Scalar::Util qw(blessed);
  10         20  
  10         561  
8 10     10   33556 use XML::LibXML;
  0            
  0            
9              
10             use VS::RuleEngine::Engine;
11             use VS::RuleEngine::Util qw(is_existing_package);
12              
13             our $VERSION = "0.03";
14              
15             sub _new {
16             my ($pkg) = @_;
17             my $self = bless {
18             }, $pkg;
19             return $self;
20             }
21              
22             sub to_file {
23             my ($self, $engine, $path) = @_;
24             my $xml = $self->_engine_to_doc($engine);
25             $xml->toFile($path);
26             }
27              
28             our $XML_FORMAT = 1;
29             sub as_xml {
30             my ($self, $engine) = @_;
31             my $doc = $self->_engine_to_doc($engine);
32             return $doc->serialize($XML_FORMAT);
33             }
34              
35             sub _engine_to_doc {
36             my ($self, $engine) = @_;
37            
38             croak "Engine is undefined" if !defined $engine;
39             croak "Not a VS::RuleEngine::Engine instance" if !(blessed $engine && $engine->isa("VS::RuleEngine::Engine"));
40            
41             my $doc = XML::LibXML::Document->new();
42             my $root = $doc->createElement("engine");
43             $doc->setDocumentElement($root);
44              
45             if (ref $engine ne "VS::RuleEngine::Engine") {
46             my $engine_class = ref $engine;
47             $root->setAttribute(instanceOf => $engine_class);
48             }
49             # Defaults
50             for my $defaults_name (sort $engine->defaults) {
51             my $values = $engine->get_defaults($defaults_name);
52             my $defaults = $doc->createElement("defaults");
53             $defaults->setAttribute(name => $defaults_name);
54             for my $key (sort keys %$values) {
55             $defaults->appendTextChild($key, $values->{$key});
56             }
57             $root->addChild($defaults)
58             }
59            
60             # Actions
61             for my $action (sort $engine->actions) {
62             my $decl = $engine->_get_action($action);
63             my $entity = _decl_to_element("action", $action, $doc, $decl);
64             $root->addChild($entity);
65             }
66              
67             # Inputs
68             for my $input (sort $engine->inputs) {
69             my $decl = $engine->_get_input($input);
70             my $entity = _decl_to_element("input", $input, $doc, $decl);
71             $root->addChild($entity);
72             }
73              
74             # Prehooks
75             for my $hook (@{$engine->_pre_hooks}) {
76             my $decl = $engine->_get_hook($hook);
77             my $entity = _decl_to_element("prehook", $hook, $doc, $decl);
78             $root->addChild($entity);
79             }
80            
81             my %actionmap;
82              
83             # Rule comes here
84             for my $rule (@{$engine->_rule_order}) {
85             my $decl = $engine->_get_rule($rule);
86             my $entity = _decl_to_element("rule", $rule, $doc, $decl);
87             $root->addChild($entity);
88            
89             for my $action (@{$engine->_get_rule_actions($rule)}) {
90             push @{$actionmap{$action}}, $rule;
91             }
92            
93             }
94            
95             # Rule -> Action mapping
96             for my $action (sort keys %actionmap) {
97             my $run = $doc->createElement("run");
98             $run->setAttribute("action" => $action);
99             for my $rule (@{$actionmap{$action}}) {
100             my $rule_elem = $doc->createElement("rule");
101             $rule_elem->appendText($rule);
102             $run->addChild($rule_elem);
103             }
104             $root->addChild($run);
105             }
106            
107             # Posthooks
108             for my $hook (@{$engine->_post_hooks}) {
109             my $decl = $engine->_get_hook($hook);
110             my $entity = _decl_to_element("posthook", $hook, $doc, $decl);
111             $root->addChild($entity);
112             }
113            
114             # Outputs
115             for my $output (sort $engine->outputs) {
116             my $decl = $engine->_get_output($output);
117             my $entity = _decl_to_element("output", $output, $doc, $decl);
118             $root->addChild($entity);
119             }
120              
121             return $doc;
122             }
123              
124             sub _decl_to_element {
125             my ($type, $name, $doc, $decl) = @_;
126            
127             my $entity = $doc->createElement($type);
128              
129             $entity->setAttribute("name" => $name);
130             $entity->setAttribute("instanceOf" => $decl->_pkg);
131            
132             my $defaults = $decl->_defaults;
133             if ($defaults && @$defaults) {
134             $entity->setAttribute("defaults" => join(", ", @$defaults));
135             }
136            
137             _args_to_element($doc, $entity, $decl->_pkg, $decl->_args);
138            
139             return $entity;
140             }
141              
142             sub _args_to_element {
143             my ($doc, $parent, $pkg, $args) = @_;
144            
145             if (!is_existing_package($pkg)) {
146             eval "require ${pkg};";
147             croak $@ if $@;
148             }
149            
150             if ($pkg->can("process_xml_writer_args")) {
151             $pkg->process_xml_writer_args($doc, $parent, @$args);
152             return;
153             }
154            
155             if (!(@$args & 1)) {
156             my %args = @$args;
157             for my $key (sort keys %args) {
158             $parent->appendTextChild($key, $args{$key});
159             }
160             }
161             }
162              
163             1;
164             __END__