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