|
1 # $Id: SAX.pm,v 1.27 2007/02/07 09:33:50 grant Exp $ |
|
2 |
|
3 package XML::SAX; |
|
4 |
|
5 use strict; |
|
6 use vars qw($VERSION @ISA @EXPORT_OK); |
|
7 |
|
8 $VERSION = '0.15'; |
|
9 |
|
10 use Exporter (); |
|
11 @ISA = ('Exporter'); |
|
12 |
|
13 @EXPORT_OK = qw(Namespaces Validation); |
|
14 |
|
15 use File::Basename qw(dirname); |
|
16 use File::Spec (); |
|
17 use Symbol qw(gensym); |
|
18 use XML::SAX::ParserFactory (); # loaded for simplicity |
|
19 |
|
20 use constant PARSER_DETAILS => "ParserDetails.ini"; |
|
21 |
|
22 use constant Namespaces => "http://xml.org/sax/features/namespaces"; |
|
23 use constant Validation => "http://xml.org/sax/features/validation"; |
|
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 my $class = shift; |
|
49 my $dir = shift; |
|
50 |
|
51 # reset parsers |
|
52 $known_parsers = []; |
|
53 |
|
54 # get directory from wherever XML::SAX is installed |
|
55 if (!$dir) { |
|
56 $dir = $INC{'XML/SAX.pm'}; |
|
57 $dir = dirname($dir); |
|
58 } |
|
59 |
|
60 my $fh = gensym(); |
|
61 if (!open($fh, File::Spec->catfile($dir, "SAX", PARSER_DETAILS))) { |
|
62 XML::SAX->do_warn("could not find " . PARSER_DETAILS . " in $dir/SAX\n"); |
|
63 return $class; |
|
64 } |
|
65 |
|
66 $known_parsers = $class->_parse_ini_file($fh); |
|
67 |
|
68 return $class; |
|
69 } |
|
70 |
|
71 sub _parse_ini_file { |
|
72 my $class = shift; |
|
73 my ($fh) = @_; |
|
74 |
|
75 my @config; |
|
76 |
|
77 my $lineno = 0; |
|
78 while (defined(my $line = <$fh>)) { |
|
79 $lineno++; |
|
80 my $original = $line; |
|
81 # strip whitespace |
|
82 $line =~ s/\s*$//m; |
|
83 $line =~ s/^\s*//m; |
|
84 # strip comments |
|
85 $line =~ s/[#;].*$//m; |
|
86 # ignore blanks |
|
87 next if $line =~ /^$/m; |
|
88 |
|
89 # heading |
|
90 if ($line =~ /^\[\s*(.*)\s*\]$/m) { |
|
91 push @config, { Name => $1 }; |
|
92 next; |
|
93 } |
|
94 |
|
95 # instruction |
|
96 elsif ($line =~ /^(.*?)\s*?=\s*(.*)$/) { |
|
97 unless(@config) { |
|
98 push @config, { Name => '' }; |
|
99 } |
|
100 $config[-1]{Features}{$1} = $2; |
|
101 } |
|
102 |
|
103 # not whitespace, comment, or instruction |
|
104 else { |
|
105 die "Invalid line in ini: $lineno\n>>> $original\n"; |
|
106 } |
|
107 } |
|
108 |
|
109 return \@config; |
|
110 } |
|
111 |
|
112 sub parsers { |
|
113 my $class = shift; |
|
114 if (!$known_parsers) { |
|
115 $class->load_parsers(); |
|
116 } |
|
117 return $known_parsers; |
|
118 } |
|
119 |
|
120 sub remove_parser { |
|
121 my $class = shift; |
|
122 my ($parser_module) = @_; |
|
123 |
|
124 if (!$known_parsers) { |
|
125 $class->load_parsers(); |
|
126 } |
|
127 |
|
128 @$known_parsers = grep { $_->{Name} ne $parser_module } @$known_parsers; |
|
129 |
|
130 return $class; |
|
131 } |
|
132 |
|
133 sub add_parser { |
|
134 my $class = shift; |
|
135 my ($parser_module) = @_; |
|
136 |
|
137 if (!$known_parsers) { |
|
138 $class->load_parsers(); |
|
139 } |
|
140 |
|
141 # first load module, then query features, then push onto known_parsers, |
|
142 |
|
143 my $parser_file = $parser_module; |
|
144 $parser_file =~ s/::/\//g; |
|
145 $parser_file .= ".pm"; |
|
146 |
|
147 require $parser_file; |
|
148 |
|
149 my @features = $parser_module->supported_features(); |
|
150 |
|
151 my $new = { Name => $parser_module }; |
|
152 foreach my $feature (@features) { |
|
153 $new->{Features}{$feature} = 1; |
|
154 } |
|
155 |
|
156 # If exists in list already, move to end. |
|
157 my $done = 0; |
|
158 my $pos = undef; |
|
159 for (my $i = 0; $i < @$known_parsers; $i++) { |
|
160 my $p = $known_parsers->[$i]; |
|
161 if ($p->{Name} eq $parser_module) { |
|
162 $pos = $i; |
|
163 } |
|
164 } |
|
165 if (defined $pos) { |
|
166 splice(@$known_parsers, $pos, 1); |
|
167 push @$known_parsers, $new; |
|
168 $done++; |
|
169 } |
|
170 |
|
171 # Otherwise (not in list), add at end of list. |
|
172 if (!$done) { |
|
173 push @$known_parsers, $new; |
|
174 } |
|
175 |
|
176 return $class; |
|
177 } |
|
178 |
|
179 sub save_parsers { |
|
180 my $class = shift; |
|
181 |
|
182 # get directory from wherever XML::SAX is installed |
|
183 my $dir = $INC{'XML/SAX.pm'}; |
|
184 $dir = dirname($dir); |
|
185 |
|
186 my $file = File::Spec->catfile($dir, "SAX", PARSER_DETAILS); |
|
187 chmod 0644, $file; |
|
188 unlink($file); |
|
189 |
|
190 my $fh = gensym(); |
|
191 open($fh, ">$file") || |
|
192 die "Cannot write to $file: $!"; |
|
193 |
|
194 foreach my $p (@$known_parsers) { |
|
195 print $fh "[$p->{Name}]\n"; |
|
196 foreach my $key (keys %{$p->{Features}}) { |
|
197 print $fh "$key = $p->{Features}{$key}\n"; |
|
198 } |
|
199 print $fh "\n"; |
|
200 } |
|
201 |
|
202 print $fh "\n"; |
|
203 |
|
204 close $fh; |
|
205 |
|
206 return $class; |
|
207 } |
|
208 |
|
209 sub do_warn { |
|
210 my $class = shift; |
|
211 # Don't output warnings if running under Test::Harness |
|
212 warn(@_) unless $ENV{HARNESS_ACTIVE}; |
|
213 } |
|
214 |
|
215 1; |
|
216 __END__ |
|
217 |
|
218 =head1 NAME |
|
219 |
|
220 XML::SAX - Simple API for XML |
|
221 |
|
222 =head1 SYNOPSIS |
|
223 |
|
224 use XML::SAX; |
|
225 |
|
226 # get a list of known parsers |
|
227 my $parsers = XML::SAX->parsers(); |
|
228 |
|
229 # add/update a parser |
|
230 XML::SAX->add_parser(q(XML::SAX::PurePerl)); |
|
231 |
|
232 # remove parser |
|
233 XML::SAX->remove_parser(q(XML::SAX::Foodelberry)); |
|
234 |
|
235 # save parsers |
|
236 XML::SAX->save_parsers(); |
|
237 |
|
238 =head1 DESCRIPTION |
|
239 |
|
240 XML::SAX is a SAX parser access API for Perl. It includes classes |
|
241 and APIs required for implementing SAX drivers, along with a factory |
|
242 class for returning any SAX parser installed on the user's system. |
|
243 |
|
244 =head1 USING A SAX2 PARSER |
|
245 |
|
246 The factory class is XML::SAX::ParserFactory. Please see the |
|
247 documentation of that module for how to instantiate a SAX parser: |
|
248 L<XML::SAX::ParserFactory>. However if you don't want to load up |
|
249 another manual page, here's a short synopsis: |
|
250 |
|
251 use XML::SAX::ParserFactory; |
|
252 use XML::SAX::XYZHandler; |
|
253 my $handler = XML::SAX::XYZHandler->new(); |
|
254 my $p = XML::SAX::ParserFactory->parser(Handler => $handler); |
|
255 $p->parse_uri("foo.xml"); |
|
256 # or $p->parse_string("<foo/>") or $p->parse_file($fh); |
|
257 |
|
258 This will automatically load a SAX2 parser (defaulting to |
|
259 XML::SAX::PurePerl if no others are found) and return it to you. |
|
260 |
|
261 In order to learn how to use SAX to parse XML, you will need to read |
|
262 L<XML::SAX::Intro> and for reference, L<XML::SAX::Specification>. |
|
263 |
|
264 =head1 WRITING A SAX2 PARSER |
|
265 |
|
266 The first thing to remember in writing a SAX2 parser is to subclass |
|
267 XML::SAX::Base. This will make your life infinitely easier, by providing |
|
268 a number of methods automagically for you. See L<XML::SAX::Base> for more |
|
269 details. |
|
270 |
|
271 When writing a SAX2 parser that is compatible with XML::SAX, you need |
|
272 to inform XML::SAX of the presence of that driver when you install it. |
|
273 In order to do that, XML::SAX contains methods for saving the fact that |
|
274 the parser exists on your system to a "INI" file, which is then loaded |
|
275 to determine which parsers are installed. |
|
276 |
|
277 The best way to do this is to follow these rules: |
|
278 |
|
279 =over 4 |
|
280 |
|
281 =item * Add XML::SAX as a prerequisite in Makefile.PL: |
|
282 |
|
283 WriteMakefile( |
|
284 ... |
|
285 PREREQ_PM => { 'XML::SAX' => 0 }, |
|
286 ... |
|
287 ); |
|
288 |
|
289 Alternatively you may wish to check for it in other ways that will |
|
290 cause more than just a warning. |
|
291 |
|
292 =item * Add the following code snippet to your Makefile.PL: |
|
293 |
|
294 sub MY::install { |
|
295 package MY; |
|
296 my $script = shift->SUPER::install(@_); |
|
297 if (ExtUtils::MakeMaker::prompt( |
|
298 "Do you want to modify ParserDetails.ini?", 'Y') |
|
299 =~ /^y/i) { |
|
300 $script =~ s/install :: (.*)$/install :: $1 install_sax_driver/m; |
|
301 $script .= <<"INSTALL"; |
|
302 |
|
303 install_sax_driver : |
|
304 \t\@\$(PERL) -MXML::SAX -e "XML::SAX->add_parser(q(\$(NAME)))->save_parsers()" |
|
305 |
|
306 INSTALL |
|
307 } |
|
308 return $script; |
|
309 } |
|
310 |
|
311 Note that you should check the output of this - \$(NAME) will use the name of |
|
312 your distribution, which may not be exactly what you want. For example XML::LibXML |
|
313 has a driver called XML::LibXML::SAX::Generator, which is used in place of |
|
314 \$(NAME) in the above. |
|
315 |
|
316 =item * Add an XML::SAX test: |
|
317 |
|
318 A test file should be added to your t/ directory containing something like the |
|
319 following: |
|
320 |
|
321 use Test; |
|
322 BEGIN { plan tests => 3 } |
|
323 use XML::SAX; |
|
324 use XML::SAX::PurePerl::DebugHandler; |
|
325 XML::SAX->add_parser(q(XML::SAX::MyDriver)); |
|
326 local $XML::SAX::ParserPackage = 'XML::SAX::MyDriver'; |
|
327 eval { |
|
328 my $handler = XML::SAX::PurePerl::DebugHandler->new(); |
|
329 ok($handler); |
|
330 my $parser = XML::SAX::ParserFactory->parser(Handler => $handler); |
|
331 ok($parser); |
|
332 ok($parser->isa('XML::SAX::MyDriver'); |
|
333 $parser->parse_string("<tag/>"); |
|
334 ok($handler->{seen}{start_element}); |
|
335 }; |
|
336 |
|
337 =back |
|
338 |
|
339 =head1 EXPORTS |
|
340 |
|
341 By default, XML::SAX exports nothing into the caller's namespace. However you |
|
342 can request the symbols C<Namespaces> and C<Validation> which are the |
|
343 URIs for those features, allowing an easier way to request those features |
|
344 via ParserFactory: |
|
345 |
|
346 use XML::SAX qw(Namespaces Validation); |
|
347 my $factory = XML::SAX::ParserFactory->new(); |
|
348 $factory->require_feature(Namespaces); |
|
349 $factory->require_feature(Validation); |
|
350 my $parser = $factory->parser(); |
|
351 |
|
352 =head1 AUTHOR |
|
353 |
|
354 Current maintainer: Grant McLean, grantm@cpan.org |
|
355 |
|
356 Originally written by: |
|
357 |
|
358 Matt Sergeant, matt@sergeant.org |
|
359 |
|
360 Kip Hampton, khampton@totalcinema.com |
|
361 |
|
362 Robin Berjon, robin@knowscape.com |
|
363 |
|
364 =head1 LICENSE |
|
365 |
|
366 This is free software, you may use it and distribute it under |
|
367 the same terms as Perl itself. |
|
368 |
|
369 =head1 SEE ALSO |
|
370 |
|
371 L<XML::SAX::Base> for writing SAX Filters and Parsers |
|
372 |
|
373 L<XML::SAX::PurePerl> for an XML parser written in 100% |
|
374 pure perl. |
|
375 |
|
376 L<XML::SAX::Exception> for details on exception handling |
|
377 |
|
378 =cut |
|
379 |