local-lib5/lib/perl5/XML/SAX.pm

   1 # $Id: SAX.pm,v 1.31 2008-08-05 12:36:24 grant Exp $
   2
   3 package XML::SAX;
   4
   5 use strict;
   6 use vars qw($VERSION @ISA @EXPORT_OK);
   7
   8 $VERSION = '0.96';
   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