File Coverage

blib/lib/PITA/XML/SAXParser.pm
Criterion Covered Total %
statement 219 229 95.6
branch 27 38 71.0
condition 7 9 77.7
subroutine 60 62 96.7
pod 4 52 7.6
total 317 390 81.2


line stmt bran cond sub pod time code
1             package PITA::XML::SAXParser;
2              
3             =pod
4              
5             =head1 NAME
6              
7             PITA::XML::SAXParser - Implements a SAX Parser for PITA::XML files
8              
9             =head1 DESCRIPTION
10              
11             Although you won't need to use it directly, this class provides a
12             "SAX Parser" class that converts a stream of SAX events (most likely from
13             an XML file) and populates a L with L
14             objects.
15              
16             Please note that this class is incomplete at this time. Although you
17             can create objects and parse some of the tags, many are still ignored
18             at this time (in particular the EoutputE and EanalysisE
19             tags.
20              
21             =head1 METHODS
22              
23             In addition to the following documented methods, this class implements
24             a large number of methods relating to its implementation of a
25             L subclass. These are not considered part of the
26             public API, and so are not documented here.
27              
28             =cut
29              
30 10     10   48 use strict;
  10         17  
  10         284  
31 10     10   45 use Carp ();
  10         18  
  10         172  
32 10     10   47 use Params::Util qw{ _INSTANCE };
  10         13  
  10         423  
33 10     10   16054 use XML::SAX::Base ();
  10         235090  
  10         316  
34              
35 10     10   139 use vars qw{$VERSION @ISA $XML_NAMESPACE @PROPERTIES %TRIM};
  10         22  
  10         2263  
36             BEGIN {
37 10     10   23 $VERSION = '0.52';
38 10         330 @ISA = 'XML::SAX::Base';
39              
40             # Define the XML namespace we are a parser for
41 10         68 $XML_NAMESPACE = 'http://ali.as/xml/schemas/PITA/1.0';
42              
43             # The name/tags for the simple properties
44 10         45 @PROPERTIES = qw{
45             id driver
46             scheme distname
47             filename resource digest
48             authority authpath
49             cmd path system
50             exitcode
51             };
52              
53             # Set up the char strings to trim
54 10         25 %TRIM = map { $_ => 1 } @PROPERTIES;
  130         319  
55              
56             # Create the property handlers
57 10     2 0 45 foreach my $name ( @PROPERTIES ) { eval <<"END_PERL" }
  130     2 0 30467  
  2     1 0 7  
  2     7 0 12  
  2     3 0 9  
  2     4 0 7  
  2     1 0 11  
  2     7 0 10  
  1     1 0 2  
  1     2 0 8  
  1     2 0 4  
  7     5 0 19  
  7     0 0 35  
  7     2 0 51  
  3     2 0 7  
  3     1 0 17  
  3     7 0 15  
  4     3 0 9  
  4     4 0 27  
  4     1 0 19  
  1     7 0 2  
  1     1 0 5  
  1     2 0 6  
  7     2 0 22  
  7     5 0 41  
  7     0 0 300  
  1         3  
  1         7  
  1         4  
  2         6  
  2         10  
  2         8  
  2         6  
  2         9  
  2         9  
  5         10  
  5         30  
  5         22  
  0         0  
  0         0  
  0         0  
  2         9  
  2         9  
  2         9  
  2         10  
  1         4  
  1         4  
  7         25  
  7         34  
  3         13  
  3         15  
  4         17  
  4         23  
  1         4  
  1         4  
  7         123  
  7         32  
  1         4  
  1         4  
  2         9  
  2         8  
  2         8  
  2         9  
  5         19  
  5         20  
  0         0  
  0         0  
58              
59             # Start capturing chars
60             sub start_element_${name} {
61             \$_[0]->{chars} = '';
62             1;
63             }
64              
65             # Save those chars to the element
66             sub end_element_${name} {
67             my \$self = shift;
68              
69             # Add the $name to the context
70             \$self->_context->{$name} = delete \$self->{chars};
71              
72             1;
73             }
74             END_PERL
75             }
76              
77              
78              
79              
80              
81             #####################################################################
82             # Constructor
83              
84             =pod
85              
86             =head2 new
87              
88             # Create the SAX parser
89             my $parser = PITA::XML::SAXParser->new( $report );
90              
91             The C constructor takes a single L object and creates
92             a SAX Parser for it. When used, the SAX Parser object will fill the empty
93             L object with L reporting objects.
94              
95             If used with a L that already has existing content, it
96             will add the new install reports in addition to the existing ones.
97              
98             Returns a new C object, or dies on error.
99              
100             =cut
101              
102             sub new {
103 10     10 1 25 my $class = shift;
104 10         75 my $root = _INSTANCE(shift, 'PITA::XML::Storable');
105 10 50       360 unless ( $root ) {
106 0         0 Carp::croak("Did not provide a PITA::XML::Storable root element");
107             }
108              
109             # Create the basic parsing object
110 10         56 my $self = bless {
111             object => $root,
112             root => $root->xml_entity,
113             context => [],
114             }, $class;
115              
116 10         108 $self;
117             }
118              
119             # Add to the context
120             sub _push {
121 35     35   57 push @{shift->{context}}, @_;
  35         112  
122 35         121 return 1;
123             }
124              
125             # Remove from the context
126             sub _pop {
127 35     35   52 my $self = shift;
128 35 50       47 unless ( @{$self->{context}} ) {
  35         105  
129 0         0 die "Ran out of context";
130             }
131 35         48 return pop @{$self->{context}};
  35         189  
132             }
133              
134             # Get the current context
135             sub _context {
136 79     79   1448 shift->{context}->[-1];
137             }
138              
139             # Convert full Attribute data into a simple hash
140             sub _hash {
141 78     78   115 my $self = shift;
142 78         528 my $attrs = shift;
143              
144             # Shrink it
145 26         127 my %hash = map {
146 26         78 $_->{LocalName}, $_->{Value}
147             } grep {
148 26         96 $_->{Value} =~ s/^\s+//;
149 26         76 $_->{Value} =~ s/\s+$//;
150 26         63 1;
151             } grep {
152 78         191 not $_->{Prefix}
153             } values %$attrs;
154              
155 78         183 return \%hash;
156             }
157              
158              
159              
160              
161              
162             #####################################################################
163             # Simplification Layer
164              
165             sub start_element {
166 78     78 1 47436 my $self = shift;
167 78         112 my $element = shift;
168              
169             # We don't support namespaces.
170 78 50       229 if ( $element->{Prefix} ) {
171 0         0 Carp::croak(
172             __PACKAGE__ .
173             ' does not support the use of XML namespaces (yet)',
174             );
175             }
176              
177             # If this is the root element, set up the initial context.
178             # (and thus don't use the normal handler)
179 78 100       97 unless ( @{$self->{context}} ) {
  78         233  
180 10 50       54 unless ( $element->{LocalName} eq $self->{root} ) {
181 0         0 Carp::croak( "Root element must be a <$self->{root}>" );
182             }
183              
184             # Support ids in the root object
185 10         53 my $hash = $self->_hash($element->{Attributes});
186 10 100       43 if ( defined $hash->{id} ) {
187 2         15 $self->{object}->{id} = $hash->{id};
188             }
189              
190             # Set up the root object as the root context
191 10         73 $self->_push( $self->{object} );
192 10         46 return 1;
193             }
194              
195             # Shortcut if we don't implement a handler
196 68         205 my $handler = 'start_element_' . $element->{LocalName};
197 68 50       410 return 1 unless $self->can($handler);
198              
199             # Hand off to the handler
200 68         377 my $hash = $self->_hash($element->{Attributes});
201 68         1478 return $self->$handler( $hash );
202             }
203              
204             sub end_element {
205 78     78 1 12321 my $self = shift;
206 78         93 my $element = shift;
207              
208             # Handle the closing root element
209 78 100 66     314 if ( $element->{LocalName} eq $self->{root} and @{$self->{context}} == 1 ) {
  10         61  
210 10         38 $self->_pop->_init;
211 9         30 return 1;
212             }
213              
214             # Hand off to the optional tag-specific handler
215 68         163 my $handler = 'end_element_' . $element->{LocalName};
216 68 50       342 return 1 unless $self->can($handler);
217              
218             # If there is anything in the character buffer, trim whitespace
219 68 100 100     564 if ( exists $self->{chars} and defined $self->{chars} ) {
220 51 100       190 if ( $TRIM{$element->{LocalName}} ) {
221 37         154 $self->{chars} =~ s/^\s+//;
222 37         293 $self->{chars} =~ s/\s+$//;
223             }
224             }
225              
226 68         1522 return $self->$handler();
227             }
228              
229             # Because we don't know in what context this will be called,
230             # we just store all character data in a character buffer
231             # and deal with it in the various end_element methods.
232             sub characters {
233 70     70 1 4041 my $self = shift;
234 70         95 my $element = shift;
235              
236             # Add to the buffer (if not null)
237 70 100 66     361 if ( exists $self->{chars} and defined $self->{chars} ) {
238 51         236 $self->{chars} .= $element->{Data};
239             }
240              
241 70         184 return 1;
242             }
243              
244              
245              
246              
247              
248             #####################################################################
249             # Handle the ... tag
250              
251             sub start_element_install {
252 1     1 0 9 $_[0]->_push(
253             bless {
254             commands => [],
255             tests => [],
256             }, 'PITA::XML::Install'
257             );
258             }
259              
260             sub end_element_install {
261 1     1 0 2 my $self = shift;
262              
263             # Complete the install and add to the report
264 1         4 my $install = $self->_pop->_init;
265 1         4 $self->_context->add_install( $install );
266              
267 1         3 return 1;
268             }
269              
270              
271              
272              
273              
274             #####################################################################
275             # Handle the ... tag
276              
277             sub start_element_request {
278 1     1 0 2 my $self = shift;
279 1         5 my $request = bless { }, 'PITA::XML::Request';
280              
281             # Add the id if it has one
282 1         2 my $attr = shift;
283 1 50       6 if ( defined $attr->{id} ) {
284 0         0 $request->{id} = $attr->{id};
285             }
286              
287 1         3 $self->_push( $request );
288             }
289              
290             sub end_element_request {
291 1     1 0 3 my $self = shift;
292              
293             # Complete the Request and add to the Install
294 1         4 $self->_context->{request} = $self->_pop->_init;
295              
296 1         5 return 1;
297             }
298              
299              
300              
301              
302              
303             #####################################################################
304             # Handle the ... tag
305              
306             sub start_element_file {
307 7     7 0 62 $_[0]->_push(
308             bless { }, 'PITA::XML::File'
309             );
310             }
311              
312             sub end_element_file {
313 7     7 0 18 my $self = shift;
314              
315             # Complete the Platform and add to the parent Install/Guest
316 7         32 my $file = $self->_pop->_init;
317 7 100       32 if ( _INSTANCE($self->_context, 'PITA::XML::Guest') ) {
    50          
318 4         30 $self->_context->add_file( $file );
319             } elsif ( _INSTANCE($self->_context, 'PITA::XML::Request') ) {
320 3         20 $self->_context->{file} = $file;
321             }
322              
323 7         30 return 1;
324             }
325              
326              
327              
328              
329              
330             #####################################################################
331             # Handle the ... tag
332              
333             sub start_element_platform {
334 2     2 0 26 $_[0]->_push(
335             bless {
336             env => {},
337             config => {},
338             }, 'PITA::XML::Platform'
339             );
340             }
341              
342             sub end_element_platform {
343 2     2 0 4 my $self = shift;
344              
345             # Complete the Platform and add to the parent Install/Guest
346 2         6 my $platform = $self->_pop->_init;
347 2 100       7 if ( _INSTANCE($self->_context, 'PITA::XML::Install') ) {
    50          
348 1         2 $self->_context->{platform} = $platform;
349             } elsif ( _INSTANCE($self->_context, 'PITA::XML::Guest') ) {
350 1         4 $self->_context->add_platform( $platform );
351             }
352              
353 2         6 return 1;
354             }
355              
356              
357              
358              
359              
360             #####################################################################
361             # Handle the ... tag
362              
363             sub start_element_command {
364 1     1 0 6 $_[0]->_push(
365             bless {}, 'PITA::XML::Command'
366             );
367             }
368              
369             sub end_element_command {
370 1     1 0 2 my $self = shift;
371              
372             # Complete the Command and add to the Install
373 1         3 my $command = $self->_pop->_init;
374 1         2 push @{ $self->_context->{commands} }, $command;
  1         3  
375              
376 1         3 return 1;
377             }
378              
379              
380              
381              
382              
383             #####################################################################
384             # Handle the ... tag
385              
386             sub start_element_test {
387 1     1 0 3 my $self = shift;
388 1         2 my $hash = shift;
389              
390             # Create the test object
391 1         5 my $test = bless {
392             language => $hash->{language},
393             }, 'PITA::XML::Test';
394 1 50       4 if ( $hash->{name} ) {
395 1         2 $test->{name} = $hash->{name};
396             }
397              
398 1         2 $self->_push( $test );
399             }
400              
401             sub end_element_test {
402 1     1 0 3 my $self = shift;
403              
404             # Complete the Command and add to the Install
405 1         4 my $test = $self->_pop->_init;
406 1         3 push @{ $self->_context->{tests} }, $test;
  1         4  
407              
408 1         5 return 1;
409             }
410              
411              
412              
413              
414              
415             #####################################################################
416             # Handle the ... tag
417              
418             # Start capturing the STDOUT content
419             sub start_element_stdout {
420 2     2 0 5 $_[0]->{chars} = '';
421 2         8 return 1;
422             }
423              
424             # Save those chars to the element by reference, not plain strings
425             sub end_element_stdout {
426 2     2 0 3 my $self = shift;
427              
428             # Add the $name to the context
429 2         6 my $stdout = delete $self->{chars};
430 2         9 $self->_context->{stdout} = \$stdout;
431              
432 2         7 return 1;
433             }
434              
435              
436              
437              
438              
439             #####################################################################
440             # Handle the ... tag
441              
442             # Start capturing the STDERR content
443             sub start_element_stderr {
444 2     2 0 6 $_[0]->{chars} = '';
445 2         6 return 1;
446             }
447              
448             # Save those chars to the element by reference, not plain strings
449             sub end_element_stderr {
450 2     2 0 5 my $self = shift;
451              
452             # Add the $name to the context
453 2         4 my $stderr = delete $self->{chars};
454 2         6 $self->_context->{stderr} = \$stderr;
455              
456 2         7 return 1;
457             }
458              
459              
460              
461              
462              
463             #####################################################################
464             # Handle the ... tag
465              
466             # Start capturing the $ENV{key} content
467             sub start_element_env {
468 2     2 0 5 my $self = shift;
469 2         4 my $hash = shift;
470 2         5 $self->{chars} = '';
471 2         6 $self->_push( $hash->{name} );
472             }
473              
474             # Save those chars to the element by reference, not plain strings
475             sub end_element_env {
476 2     2 0 4 my $self = shift;
477              
478             # Add the vey/value pair to the env propery
479 2         5 my $name = $self->_pop;
480 2         5 my $value = delete $self->{chars};
481 2         7 $self->_context->{env}->{$name} = $value;
482              
483 2         6 return 1;
484             }
485              
486              
487              
488              
489              
490             #####################################################################
491             # Handle the ... tag
492              
493             # Start capturing the %Config::Config content
494             sub start_element_config {
495 10     10 0 19 my $self = shift;
496 10         17 my $hash = shift;
497 10         21 $self->{chars} = '';
498 10         31 $self->_push( $hash->{name} );
499             }
500              
501             # Save those chars to the element by reference, not plain strings
502             sub end_element_config {
503 10     10 0 17 my $self = shift;
504              
505             # Add the vey/value pair to the config propery
506 10         23 my $name = $self->_pop;
507 10         25 my $value = delete $self->{chars};
508 10         24 $self->_context->{config}->{$name} = $value;
509              
510 10         35 return 1;
511             }
512              
513              
514              
515              
516              
517             #####################################################################
518             # Handle tags in a variety of things
519              
520             sub start_element_null {
521 2     2 0 5 my $self = shift;
522 2         5 my $hash = shift;
523              
524             # A null tag indicates that the currently-accumulating character
525             # buffer should be set to undef.
526 2 50       8 if ( exists $self->{chars} ) {
527 2         5 $self->{chars} = undef;
528             }
529              
530 2         6 return 1;
531             }
532              
533             sub end_element_null {
534 2     2 0 7 return 1;
535             }
536              
537             1;
538              
539             =pod
540              
541             =head1 SUPPORT
542              
543             Bugs should be reported via the CPAN bug tracker at
544              
545             L
546              
547             For other issues, contact the author.
548              
549             =head1 AUTHOR
550              
551             Adam Kennedy Eadamk@cpan.orgE, L
552              
553             =head1 SEE ALSO
554              
555             L, L
556              
557             The Perl Image-based Testing Architecture (L)
558              
559             =head1 COPYRIGHT
560              
561             Copyright 2005 - 2013 Adam Kennedy.
562              
563             This program is free software; you can redistribute
564             it and/or modify it under the same terms as Perl itself.
565              
566             The full text of the license can be found in the
567             LICENSE file included with this module.
568              
569             =cut