File Coverage

blib/lib/Template/Flute/Specification/XML.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package Template::Flute::Specification::XML;
2              
3 1     1   4 use strict;
  1         1  
  1         22  
4 1     1   2 use warnings;
  1         1  
  1         16  
5              
6 1     1   1839 use XML::Twig;
  0            
  0            
7              
8             use Template::Flute::Specification;
9              
10             =head1 NAME
11              
12             Template::Flute::Specification::XML - XML Specification Parser
13              
14             =head1 SYNOPSIS
15              
16             $xml = new Template::Flute::Specification::XML;
17              
18             $spec = $xml->parse_file($specification_file);
19             $spec = $xml->parse($specification_text);
20              
21             =head1 CONSTRUCTOR
22              
23             =head2 new
24              
25             Create a Template::Flute::Specification::XML object.
26              
27             =cut
28              
29             # Constructor
30              
31             sub new {
32             my ($class, $self);
33             my (%params);
34              
35             $class = shift;
36             %params = @_;
37              
38             $self = \%params;
39             bless $self, $class;
40             }
41              
42             =head1 METHODS
43              
44             =head2 parse [ STRING | SCALARREF ]
45              
46             Parses text from STRING or SCALARREF and returns L
47             object in case of success.
48              
49             =cut
50              
51             sub parse {
52             my ($self, $text) = @_;
53             my ($twig, $xml);
54              
55             $twig = $self->_initialize;
56              
57             if (ref($text) eq 'SCALAR') {
58             $xml = $twig->safe_parse($$text);
59             }
60             else {
61             $xml = $twig->parse($text);
62             }
63              
64             unless ($xml) {
65             $self->_add_error(error => $@);
66             return;
67             }
68             $self->{spec}->{xml} = $xml;
69            
70             return $self->{spec};
71             }
72              
73             =head2 parse_file STRING
74              
75             Parses file and returns L object in
76             case of success.
77              
78             =cut
79            
80             sub parse_file {
81             my ($self, $file) = @_;
82             my ($twig, $xml);
83              
84             $twig = $self->_initialize;
85            
86             $self->{spec}->{xml} = $twig->safe_parsefile($file);
87              
88             unless ($self->{spec}->{xml}) {
89             $self->_add_error(file => $file, error => $@);
90             return;
91             }
92              
93             return $self->{spec};
94             }
95              
96             sub _initialize {
97             my $self = shift;
98             my (%handlers, $twig);
99            
100             # initialize stash
101             $self->{stash} = [];
102            
103             # specification object
104             $self->{spec} = new Template::Flute::Specification;
105              
106             # twig handlers
107             %handlers = (specification => sub {$self->_spec_handler($_[1])},
108             container => sub {$self->_container_handler($_[1])},
109             list => sub {$self->_list_handler($_[1])},
110             paging => sub {$self->_paging_handler($_[1])},
111             filter => sub {$self->_stash_handler($_[1])},
112             separator => sub {$self->_stash_handler($_[1])},
113             form => sub {$self->_form_handler($_[1])},
114             param => sub {$self->_stash_handler($_[1])},
115             value => sub {$self->_stash_handler($_[1])},
116             field => sub {$self->_stash_handler($_[1])},
117             i18n => sub {$self->_i18n_handler($_[1])},
118             input => sub {$self->_stash_handler($_[1])},
119             sort => sub {$self->_sort_handler($_[1])},
120             pattern => sub { $self->_pattern_handler($_[1]) },
121             );
122            
123             # twig parser object
124             $twig = new XML::Twig (twig_handlers => \%handlers);
125              
126             return $twig;
127             }
128              
129              
130             sub _pattern_handler {
131             my ($self, $elt) = @_;
132             # print "###" . $elt->sprint . "###\n";
133             my $name = $elt->att('name') or die "Missing name for pattern";
134             my $type = $elt->att('type') or die "Missing type for pattern $name";
135             my $content = $elt->text;
136              
137             if (! defined $content || length($content) == 0) {
138             die "Missing content for pattern $name";
139             }
140              
141             # print "### $name $type $content ###\n";
142             # always conver the content to a compiled regexp
143             my $regexp;
144             if ($type eq 'string') {
145             $regexp = qr/\Q$content\E/;
146             }
147             elsif ($type eq 'regexp') {
148             $regexp = qr/$content/;
149             }
150             else {
151             die "Wrong pattern type $type! Only string and regexp are supported";
152             }
153             $self->{spec}->pattern_add({ name => $name, regexp => $regexp });
154             }
155              
156             sub _spec_handler {
157             my ($self, $elt) = @_;
158             my ($value);
159              
160             if ($value = $elt->att('name')) {
161             $self->{spec}->name($value);
162             }
163              
164             if ($value = $elt->att('encoding')) {
165             $self->{spec}->encoding($value);
166             }
167              
168             # add values remaining on the stash
169             for my $stash_elt (@{$self->{stash}}) {
170             if ($stash_elt->gi() eq 'value') {
171             $self->_value_handler($stash_elt);
172             }
173             else {
174             die "Unexpected element left on stash: ", $stash_elt->sprint;
175             }
176             }
177             }
178              
179             sub _container_handler {
180             my ($self, $elt) = @_;
181             my ($name, %container);
182            
183             $name = $elt->att('name');
184            
185             $container{container} = $elt->atts();
186              
187             if ($elt->parent && $elt->parent->gi ne 'specification') {
188             $self->_stash_handler($elt);
189             }
190             else {
191             # flush elements from stash into container hash
192             $self->_stash_flush($elt, \%container);
193              
194             # add container to specification object
195             $self->{spec}->container_add(\%container);
196             }
197             }
198              
199             sub _list_handler {
200             my ($self, $elt) = @_;
201             my ($name, %list);
202            
203             $name = $elt->att('name');
204              
205             $list{list} = $elt->atts();
206            
207             # flush elements from stash into list hash
208             $self->_stash_flush($elt, \%list);
209              
210             # add list to specification object
211             $self->{spec}->list_add(\%list);
212             }
213              
214             sub _paging_handler {
215             my ($self, $elt) = @_;
216             my ($name, %paging, %paging_elts);
217              
218             $name = $elt->att('name');
219              
220             $paging{paging} = $elt->atts();
221              
222             for my $child ($elt->children()) {
223             if ($child->gi() eq 'element') {
224             $paging_elts{$child->att('type')} = {type => $child->att('type'),
225             name => $child->att('name'),
226             };
227             }
228             else {
229             die "Invalid child for paging $name.\n";
230             }
231             }
232              
233             unless (keys %paging_elts) {
234             die "Empty paging $name.\n";
235             }
236              
237             $paging{paging}->{elements} = \%paging_elts;
238              
239             $self->{spec}->paging_add(\%paging);
240             }
241              
242             sub _sort_handler {
243             my ($self, $elt) = @_;
244             my (@ops, $name);
245              
246             $name = $elt->att('name');
247            
248             for my $child ($elt->children()) {
249             if ($child->gi() eq 'field') {
250             push (@ops, {type => 'field',
251             name => $child->att('name'),
252             direction => $child->att('direction')});
253             }
254             else {
255             die "Invalid child for sort $name.\n";
256             }
257             }
258              
259             unless (@ops) {
260             die "Empty sort $name.\n";
261             }
262            
263             $elt->set_att('ops', \@ops);
264              
265             # flush elements from stash
266             $self->_stash_flush($elt, {});
267            
268             push @{$self->{stash}}, $elt;
269             }
270              
271             sub _stash_handler {
272             my ($self, $elt) = @_;
273              
274             push @{$self->{stash}}, $elt;
275             }
276              
277             sub _form_handler {
278             my ($self, $elt) = @_;
279             my ($name, %form);
280            
281             $name = $elt->att('name');
282            
283             $form{form} = $elt->atts();
284              
285             # flush elements from stash into form hash
286             $self->_stash_flush($elt, \%form);
287            
288             # add form to specification object
289             $self->{spec}->form_add(\%form);
290             }
291              
292             sub _value_handler {
293             my ($self, $elt) = @_;
294             my (%value);
295              
296             $value{value} = $elt->atts();
297            
298             $self->{spec}->value_add(\%value);
299             }
300              
301             sub _i18n_handler {
302             my ($self, $elt) = @_;
303             my (%i18n);
304              
305             $i18n{value} = $elt->atts();
306            
307             $self->{spec}->i18n_add(\%i18n);
308             }
309              
310             sub _stash_flush {
311             my ($self, $elt, $hashref) = @_;
312             my (@stash);
313              
314             # examine stash
315             for my $item_elt (@{$self->{stash}}) {
316             # check whether we are really the parent
317             if ($item_elt->parent() eq $elt) {
318             push (@{$hashref->{$item_elt->gi()}}, $item_elt->atts());
319             }
320             elsif ($elt->gi eq 'list'
321             && $item_elt->parent->gi eq 'container') {
322             push (@{$hashref->{$item_elt->gi()}}, {%{$item_elt->atts()}, container => $item_elt->parent->att('name')});
323             }
324             else {
325             push (@stash, $item_elt);
326             }
327             }
328              
329             # clear stash
330             $self->{stash} = \@stash;
331              
332             return;
333             }
334              
335             =head2 error
336              
337             Returns last error.
338              
339             =cut
340              
341             sub error {
342             my ($self) = @_;
343              
344             if (@{$self->{errors}}) {
345             return $self->{errors}->[0]->{error};
346             }
347             }
348              
349             sub _add_error {
350             my ($self, @args) = @_;
351             my (%error);
352              
353             %error = @args;
354            
355             unshift (@{$self->{errors}}, \%error);
356             }
357              
358             =head1 AUTHOR
359              
360             Stefan Hornburg (Racke),
361              
362             =head1 LICENSE AND COPYRIGHT
363              
364             Copyright 2010-2016 Stefan Hornburg (Racke) .
365              
366             This program is free software; you can redistribute it and/or modify it
367             under the terms of either: the GNU General Public License as published
368             by the Free Software Foundation; or the Artistic License.
369              
370             See http://dev.perl.org/licenses/ for more information.
371              
372             =cut
373              
374             1;