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__ |