File Coverage

blib/lib/PITA/XML.pm
Criterion Covered Total %
statement 102 120 85.0
branch 23 40 57.5
condition 7 15 46.6
subroutine 32 34 94.1
pod 0 1 0.0
total 164 210 78.1


line stmt bran cond sub pod time code
1             package PITA::XML;
2              
3             # See POD at end for docs.
4              
5 10     10   277838 use 5.006;
  10         38  
  10         409  
6 10     10   54 use strict;
  10         20  
  10         315  
7 10     10   136 use Carp ();
  10         26  
  10         216  
8 10     10   8717 use Params::Util ();
  10         57882  
  10         215  
9 10     10   10013 use IO::File ();
  10         119119  
  10         235  
10 10     10   9838 use IO::String ();
  10         30106  
  10         435  
11             BEGIN {
12             # Temporary Hack:
13             # IO::String looks like a duck and quacks liks a duck, but we need it
14             # to be a real duck. So lets make it a duck (if it didn't turn into a
15             # real duck while we weren't looking.)
16 10 50   10   94 unless ( @IO::String::ISA ) {
17 10         361 @IO::String::ISA = qw{ IO::Handle IO::Seekable };
18             }
19             }
20 10     10   10927 use File::ShareDir ();
  10         81489  
  10         406  
21 10     10   9797 use XML::SAX::ParserFactory ();
  10         52055  
  10         390  
22              
23             # Optionally load the schema validator
24             BEGIN {
25 10     10   26 local $@;
26 10         120 eval {
27 10         5990 require XML::Validator::Schema;
28             };
29             }
30              
31 10     10   47 use vars qw{$VERSION};
  10         18  
  10         438  
32             BEGIN {
33 10     10   206 $VERSION = '0.52';
34             }
35              
36             # The XML Schema File
37             # Locate the Schema at use-time (instead of compile-time) and
38             # allow the specification of a custom schema.
39 10     10   44 use vars qw{$SCHEMA};
  10         17  
  10         607  
40             $SCHEMA ||= File::ShareDir::dist_file('PITA-XML', 'pita-xml.xsd');
41              
42             # While in development, use a version-specific namespace.
43             # In theory, this ensures documents are only truly valid with the
44             # version they were created with.
45 10     10   53 use constant XMLNS => "http://ali.as/xml/schema/pita-xml/$VERSION";
  10         27  
  10         653  
46              
47             # The list of core schemes
48 10     10   56 use vars qw{%SCHEMES};
  10         14  
  10         687  
49             BEGIN {
50 10     10   248 %SCHEMES = (
51             'perl5' => 1,
52             'perl5.make' => 1,
53             'perl5.build' => 1,
54             'perl6' => 1,
55             );
56             }
57              
58             # Load the various classes
59 10     10   6582 use PITA::XML::Storable ();
  10         23  
  10         160  
60 10     10   5325 use PITA::XML::Command ();
  10         20  
  10         175  
61 10     10   5300 use PITA::XML::Test ();
  10         27  
  10         169  
62 10     10   5854 use PITA::XML::Request ();
  10         31  
  10         203  
63 10     10   5625 use PITA::XML::Platform ();
  10         27  
  10         176  
64 10     10   5097 use PITA::XML::File ();
  10         31  
  10         201  
65 10     10   11793 use PITA::XML::Guest ();
  10         28  
  10         188  
66 10     10   6034 use PITA::XML::Install ();
  10         29  
  10         1513  
67 10     10   5448 use PITA::XML::Report ();
  10         27  
  10         1424  
68 10     10   6594 use PITA::XML::SAXParser ();
  10         37  
  10         261  
69 10     10   7487 use PITA::XML::SAXDriver ();
  10         45  
  10         8509  
70              
71              
72              
73              
74              
75             #####################################################################
76             # Main Methods
77              
78             sub validate {
79 0     0 0 0 my $class = shift;
80 0         0 my $fh = $class->_FH(shift);
81              
82             # Make schema validation dependant on module availability
83 0 0       0 $XML::Validator::Schema::VERSION or return 1;
84              
85             # Create the validator
86 0         0 my $parser = XML::SAX::ParserFactory->parser(
87             Handler => XML::Validator::Schema->new(
88             file => $SCHEMA,
89             ),
90             );
91              
92             # Validate the document
93 0         0 $parser->parse_file( $fh );
94              
95 0         0 1;
96             }
97              
98              
99              
100              
101             #####################################################################
102             # Support Methods
103              
104             sub _FH {
105 10     10   24 my $class = shift;
106 10         22 my $file = shift;
107 10 100       66 if ( Params::Util::_SCALAR($file) ) {
108 8         84 $file = IO::String->new( $file );
109             }
110 10 100       596 if ( Params::Util::_INSTANCE($file, 'IO::Handle') ) {
111 8 50       339 if ( $file->can('seek') ) {
112             # Reset the file handle
113 8 50       64 $file->seek( 0, 0 ) or Carp::croak(
114             'Failed to reset file handle (seek to 0)',
115             );
116 8         187 return $file;
117             }
118 0         0 Carp::croak('IO::Handle is not seekable');
119             }
120 2 50 33     29 unless ( defined $file and ! ref $file and length $file ) {
      33        
121 0         0 Carp::croak('Did not provide a file name or handle');
122             }
123 2 50 33     62 unless ( $file and -f $file and -r _ ) {
      33        
124 0         0 Carp::croak('Did not provide a readable file name');
125             }
126 2         26 my $fh = IO::File->new( $file );
127 2 50       235 unless ( $fh ) {
128 0         0 Carp::croak("Failed to open PITA::XML file '$file'");
129             }
130 2         11 $fh;
131             }
132              
133             sub _OUTPUT {
134 11     11   21 my ($class, $object, $name) = @_;
135              
136             # If provided as a param, clean it up
137 11 50       32 if ( exists $object->{$name} ) {
138             # Convert from array to scalar ref
139 11 50       43 if ( Params::Util::_ARRAY0($object->{$name}) ) {
140             # Clean up newlines and merge into SCALAR
141 0         0 my $param = $object->{$name};
142 0         0 foreach my $i ( 0 .. $#$param ) {
143 0         0 $param->[$i] =~ s/[\012\015]+$/\n/;
144             }
145 0         0 $param = join '', @$param;
146 0         0 $object->{$name} = \$param;
147             }
148             }
149              
150             # Check for scalarness
151 11 50       41 Params::Util::_SCALAR0($object->$name()) ? 1 : undef;
152             }
153              
154             sub _SCHEME {
155 60     60   91 my $class = shift;
156 60 100       295 my $string = Params::Util::_STRING(shift) or return undef;
157 33 100 100     251 ($SCHEMES{$string} or $string =~ /x_/) ? $string : undef;
158             }
159              
160             sub _MD5SUM {
161 0     0   0 my $class = shift;
162 0 0       0 my $md5sum = Params::Util::_STRING(shift) or return undef;
163 0 0       0 ($md5sum =~ /^[0-9a-f]{32}$/i) ? lc($md5sum) : undef;
164             }
165              
166             sub _DISTNAME {
167 21     21   35 my $class = shift;
168 21 100       81 my $distname = Params::Util::_STRING(shift) or return undef;
169 20 100       168 ($distname =~ /^[a-z]\w*(?:\-[a-z]\w*)+$/is) ? $distname : undef;
170             }
171              
172             sub _GUID {
173 6     6   15 my $class = shift;
174 6 50       33 my $guid = Params::Util::_STRING(shift) or return undef;
175 6 50       66 ($guid =~ /^[0-9A-F]{8}-[0-9A-F]{4}-[0-9A-F]{4}-[0-9A-F]{4}-[0-9A-F]{12}$/) ? $guid : undef;
176             }
177              
178             1;
179              
180             __END__