File Coverage

blib/lib/XML/SAX.pm
Criterion Covered Total %
statement 94 116 81.0
branch 15 28 53.5
condition n/a
subroutine 16 17 94.1
pod 0 6 0.0
total 125 167 74.8


line stmt bran cond sub pod time code
1             # $Id$
2              
3             package XML::SAX;
4              
5 13     13   814967 use strict;
  13         28  
  13         818  
6 13     13   97 use vars qw($VERSION @ISA @EXPORT_OK);
  13         28  
  13         1177  
7              
8             $VERSION = '0.99';
9              
10 13     13   79 use Exporter ();
  13         35  
  13         539  
11             @ISA = ('Exporter');
12              
13             @EXPORT_OK = qw(Namespaces Validation);
14              
15 13     13   89 use File::Basename qw(dirname);
  13         142  
  13         1876  
16 13     13   98 use File::Spec ();
  13         124  
  13         299  
17 13     13   3038 use Symbol qw(gensym);
  13         3252  
  13         995  
18 13     13   470704 use XML::SAX::ParserFactory (); # loaded for simplicity
  13         124  
  13         318  
19              
20 13     13   94 use constant PARSER_DETAILS => "ParserDetails.ini";
  13         36  
  13         950  
21              
22 13     13   124 use constant Namespaces => "http://xml.org/sax/features/namespaces";
  13         25  
  13         777  
23 13     13   67 use constant Validation => "http://xml.org/sax/features/validation";
  13         27  
  13         16433  
24              
25             my $known_parsers = undef;
26              
27             # load_parsers takes the ParserDetails.ini file out of the same directory
28             # that XML::SAX is in, and looks at it. Format in POD below
29              
30             =begin EXAMPLE
31              
32             [XML::SAX::PurePerl]
33             http://xml.org/sax/features/namespaces = 1
34             http://xml.org/sax/features/validation = 0
35             # a comment
36              
37             # blank lines ignored
38              
39             [XML::SAX::AnotherParser]
40             http://xml.org/sax/features/namespaces = 0
41             http://xml.org/sax/features/validation = 1
42              
43             =end EXAMPLE
44              
45             =cut
46              
47             sub load_parsers {
48 3     3 0 7 my $class = shift;
49 3         5 my $dir = shift;
50            
51             # reset parsers
52 3         10 $known_parsers = [];
53            
54             # get directory from wherever XML::SAX is installed
55 3 50       61 if (!$dir) {
56 3         10 $dir = $INC{'XML/SAX.pm'};
57 3         194 $dir = dirname($dir);
58             }
59            
60 3         19 my $fh = gensym();
61 3 50       324 if (!open($fh, File::Spec->catfile($dir, "SAX", PARSER_DETAILS))) {
62 0         0 XML::SAX->do_warn("could not find " . PARSER_DETAILS . " in $dir/SAX\n");
63 0         0 return $class;
64             }
65              
66 3         24 $known_parsers = $class->_parse_ini_file($fh);
67              
68 3         41 return $class;
69             }
70              
71             sub _parse_ini_file {
72 8     8   22 my $class = shift;
73 8         15 my ($fh) = @_;
74              
75 8         23 my @config;
76            
77 8         16 my $lineno = 0;
78 8         197 while (defined(my $line = <$fh>)) {
79 8         19 $lineno++;
80 8         20 my $original = $line;
81             # strip whitespace
82 8         83 $line =~ s/\s*$//m;
83 8         38 $line =~ s/^\s*//m;
84             # strip comments
85 8         26 $line =~ s/[#;].*$//m;
86             # ignore blanks
87 8 100       52 next if $line =~ /^$/m;
88            
89             # heading
90 5 50       72 if ($line =~ /^\[\s*(.*)\s*\]$/m) {
    50          
91 0         0 push @config, { Name => $1 };
92 0         0 next;
93             }
94            
95             # instruction
96             elsif ($line =~ /^(.*?)\s*?=\s*(.*)$/) {
97 5 50       15 unless(@config) {
98 5         23 push @config, { Name => '' };
99             }
100 5         75 $config[-1]{Features}{$1} = $2;
101             }
102              
103             # not whitespace, comment, or instruction
104             else {
105 0         0 die "Invalid line in ini: $lineno\n>>> $original\n";
106             }
107             }
108              
109 8         31 return \@config;
110             }
111              
112             sub parsers {
113 15     15 0 1414 my $class = shift;
114 15 100       46 if (!$known_parsers) {
115 2         9 $class->load_parsers();
116             }
117 15         289 return $known_parsers;
118             }
119              
120             sub remove_parser {
121 0     0 0 0 my $class = shift;
122 0         0 my ($parser_module) = @_;
123              
124 0 0       0 if (!$known_parsers) {
125 0         0 $class->load_parsers();
126             }
127            
128 0         0 @$known_parsers = grep { $_->{Name} ne $parser_module } @$known_parsers;
  0         0  
129              
130 0         0 return $class;
131             }
132            
133             sub add_parser {
134 3     3 0 331 my $class = shift;
135 3         5 my ($parser_module) = @_;
136              
137 3 50       13 if (!$known_parsers) {
138 0         0 $class->load_parsers();
139             }
140            
141             # first load module, then query features, then push onto known_parsers,
142            
143 3         7 my $parser_file = $parser_module;
144 3         14 $parser_file =~ s/::/\//g;
145 3         6 $parser_file .= ".pm";
146              
147 3         1488 require $parser_file;
148              
149 3         36 my @features = $parser_module->supported_features();
150            
151 3         22 my $new = { Name => $parser_module };
152 3         9 foreach my $feature (@features) {
153 3         18 $new->{Features}{$feature} = 1;
154             }
155              
156             # If exists in list already, move to end.
157 3         6 my $done = 0;
158 3         7 my $pos = undef;
159 3         16 for (my $i = 0; $i < @$known_parsers; $i++) {
160 1         3 my $p = $known_parsers->[$i];
161 1 50       7 if ($p->{Name} eq $parser_module) {
162 0         0 $pos = $i;
163             }
164             }
165 3 50       11 if (defined $pos) {
166 0         0 splice(@$known_parsers, $pos, 1);
167 0         0 push @$known_parsers, $new;
168 0         0 $done++;
169             }
170              
171             # Otherwise (not in list), add at end of list.
172 3 50       11 if (!$done) {
173 3         9 push @$known_parsers, $new;
174             }
175            
176 3         19 return $class;
177             }
178              
179             sub save_parsers {
180 1     1 0 13 my $class = shift;
181            
182             # get directory from wherever XML::SAX is installed
183 1         3 my $dir = $INC{'XML/SAX.pm'};
184 1         79 $dir = dirname($dir);
185            
186 1         31 my $file = File::Spec->catfile($dir, "SAX", PARSER_DETAILS);
187 1         100 chmod 0644, $file;
188 1         138 unlink($file);
189            
190 1         30 my $fh = gensym();
191 1 50       129 open($fh, ">$file") ||
192             die "Cannot write to $file: $!";
193              
194 1         5 foreach my $p (@$known_parsers) {
195 0         0 print $fh "[$p->{Name}]\n";
196 0         0 foreach my $key (keys %{$p->{Features}}) {
  0         0  
197 0         0 print $fh "$key = $p->{Features}{$key}\n";
198             }
199 0         0 print $fh "\n";
200             }
201              
202 1         21 print $fh "\n";
203              
204 1         52 close $fh;
205              
206 1         11 return $class;
207             }
208              
209             sub do_warn {
210 1     1 0 3 my $class = shift;
211             # Don't output warnings if running under Test::Harness
212 1 50       8 warn(@_) unless $ENV{HARNESS_ACTIVE};
213             }
214              
215             1;
216             __END__