parser.pm

one of the linux gd libraries

# XML::Parser
#
# Copyright (c) 1998-2000 Larry Wall and Clark Cooper
# All rights reserved.
#
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package XML::Parser;

use Carp;

BEGIN {
  require XML::Parser::Expat;
  $VERSION = '2.34';
  die "Parser.pm and Expat.pm versions don't match"
    unless $VERSION eq $XML::Parser::Expat::VERSION;
}

use strict;

use vars qw($VERSION $LWP_load_failed);

$LWP_load_failed = 0;

sub new {
  my ($class, %args) = @_;
  my $style = $args{Style};
  
  my $nonexopt = $args{Non_Expat_Options} ||= {};
  
  $nonexopt->{Style}             = 1;
  $nonexopt->{Non_Expat_Options} = 1;
  $nonexopt->{Handlers}          = 1;
  $nonexopt->{_HNDL_TYPES}       = 1;
  $nonexopt->{NoLWP}             = 1;
  
  $args{_HNDL_TYPES} = {%XML::Parser::Expat::Handler_Setters};
  $args{_HNDL_TYPES}->{Init} = 1;
  $args{_HNDL_TYPES}->{Final} = 1;
  
  $args{Handlers} ||= {};
  my $handlers = $args{Handlers};
  
  if (defined($style)) {
    my $stylepkg = $style;
    
    if ($stylepkg !~ /::/) {
      $stylepkg = "\u$style";
      
      eval {
          my $fullpkg = 'XML::Parser::Style::' . $stylepkg;
          my $stylefile = $fullpkg;
          $stylefile =~ s/::/\//g;
          require "$stylefile.pm";
          $stylepkg = $fullpkg;
      };
      if ($@) {
          # fallback to old behaviour
          $stylepkg = 'XML::Parser::' . $stylepkg;
      }
    }
    
    my $htype;
    foreach $htype (keys %{$args{_HNDL_TYPES}}) {
      # Handlers explicity given override
      # handlers from the Style package
      unless (defined($handlers->{$htype})) {
        
        # A handler in the style package must either have
        # exactly the right case as the type name or a
        # completely lower case version of it.
        
        my $hname = "${stylepkg}::$htype";
        if (defined(&$hname)) {
          $handlers->{$htype} = \&$hname;
          next;
        }
        
        $hname = "${stylepkg}::\L$htype";
        if (defined(&$hname)) {
          $handlers->{$htype} = \&$hname;
          next;
        }
      }
    }
  }
  
  unless (defined($handlers->{ExternEnt})
          or defined ($handlers->{ExternEntFin})) {
    
    if ($args{NoLWP} or $LWP_load_failed) {
      $handlers->{ExternEnt} = \&file_ext_ent_handler;
      $handlers->{ExternEntFin} = \&file_ext_ent_cleanup;
    }
    else {
      # The following just bootstraps the real LWP external entity
      # handler

      $handlers->{ExternEnt} = \&initial_ext_ent_handler;

      # No cleanup function available until LWPExternEnt.pl loaded
    }
  }

  $args{Pkg} ||= caller;
  bless \%args, $class;
}                                # End of new

sub setHandlers {
  my ($self, @handler_pairs) = @_;
  
  croak("Uneven number of arguments to setHandlers method")
    if (int(@handler_pairs) & 1);
  
  my @ret;
  while (@handler_pairs) {
    my $type = shift @handler_pairs;
    my $handler = shift @handler_pairs;
    unless (defined($self->{_HNDL_TYPES}->{$type})) {
      my @types = sort keys %{$self->{_HNDL_TYPES}};
      
      croak("Unknown Parser handler type: $type\n Valid types: @types");
    }
    push(@ret, $type, $self->{Handlers}->{$type});
    $self->{Handlers}->{$type} = $handler;
  }

  return @ret;
}

sub parse_start {
  my $self = shift;
  my @expat_options = ();

  my ($key, $val);
  while (($key, $val) = each %{$self}) {
    push (@expat_options, $key, $val)
      unless exists $self->{Non_Expat_Options}->{$key};
  }

  my %handlers = %{$self->{Handlers}};
  my $init = delete $handlers{Init};
  my $final = delete $handlers{Final};

  my $expatnb = new XML::Parser::ExpatNB(@expat_options, @_);
  $expatnb->setHandlers(%handlers);

  &$init($expatnb)
    if defined($init);

  $expatnb->{_State_} = 1;

  $expatnb->{FinalHandler} = $final
    if defined($final);

  return $expatnb;
}

sub parse {
  my $self = shift;
  my $arg  = shift;
  my @expat_options = ();
  my ($key, $val);
  while (($key, $val) = each %{$self}) {
    push(@expat_options, $key, $val)
      unless exists $self->{Non_Expat_Options}->{$key};
  }
  
  my $expat = new XML::Parser::Expat(@expat_options, @_);
  my %handlers = %{$self->{Handlers}};
  my $init = delete $handlers{Init};
  my $final = delete $handlers{Final};
  
  $expat->setHandlers(%handlers);
  
  if ($self->{Base}) {
    $expat->base($self->{Base});
  }

  &$init($expat)
    if defined($init);
  
  my @result = ();
  my $result;
  eval {
    $result = $expat->parse($arg);
  };
  my $err = $@;
  if ($err) {
    $expat->release;
    die $err;
  }
  
  if ($result and defined($final)) {
    if (wantarray) {
      @result = &$final($expat);
    }
    else {
      $result = &$final($expat);
    }
  }
  
  $expat->release;

  return unless defined wantarray;
  return wantarray ? @result : $result;
}

sub parsestring {
  my $self = shift;
  $self->parse(@_);
}

sub parsefile {
  my $self = shift;
  my $file = shift;
  local(*FILE);
  open(FILE, $file) or  croak "Couldn't open $file:\n$!";
  binmode(FILE);
  my @ret;
  my $ret;

  $self->{Base} = $file;

  if (wantarray) {
    eval {
      @ret = $self->parse(*FILE, @_);
    };
  }
  else {
    eval {
      $ret = $self->parse(*FILE, @_);
    };
  }
  my $err = $@;
  close(FILE);
  die $err if $err;
  
  return unless defined wantarray;
  return wantarray ? @ret : $ret;
}

sub initial_ext_ent_handler {
  # This just bootstraps in the real lwp_ext_ent_handler which
  # also loads the URI and LWP modules.

  unless ($LWP_load_failed) {
    local($^W) = 0;

    my $stat =
      eval {
        require('XML/Parser/LWPExternEnt.pl');
      };
      
    if ($stat) {
      $_[0]->setHandlers(ExternEnt    => \&lwp_ext_ent_handler,
                         ExternEntFin => \&lwp_ext_ent_cleanup);
                       
      goto &lwp_ext_ent_handler;
    }

    # Failed to load lwp handler, act as if NoLWP

    $LWP_load_failed = 1;

    my $cmsg = "Couldn't load LWP based external entity handler\n";
    $cmsg .= "Switching to file-based external entity handler\n";
    $cmsg .= " (To avoid this message, use NoLWP option to XML::Parser)\n";
    warn($cmsg);
  }

  $_[0]->setHandlers(ExternEnt    => \&file_ext_ent_handler,
                     ExternEntFin => \&file_ext_ent_cleanup);
  goto &file_ext_ent_handler;

}

sub file_ext_ent_handler {
  my ($xp, $base, $path) = @_;

  # Prepend base only for relative paths

  if (defined($base)
      and not ($path =~ m!^(?:[\\/]|\w+:)!))
    {
      my $newpath = $base;
      $newpath =~ s![^\\/:]*$!$path!;
      $path = $newpath;
    }

  if ($path =~ /^\s*[|>+]/
      or $path =~ /\|\s*$/) {
    $xp->{ErrorMessage}
        .= "System ID ($path) contains Perl IO control characters";
    return undef;
  }

  require IO::File;
  my $fh = new IO::File($path);
  unless (defined $fh) {
    $xp->{ErrorMessage}
      .= "Failed to open $path:\n$!";
    return undef;
  }

  $xp->{_BaseStack} ||= [];
  $xp->{_FhStack} ||= [];

  push(@{$xp->{_BaseStack}}, $base);
  push(@{$xp->{_FhStack}}, $fh);

  $xp->base($path);
  
  return $fh;
}

sub file_ext_ent_cleanup {
  my ($xp) = @_;

  my $fh = pop(@{$xp->{_FhStack}});
  $fh->close;

  my $base = pop(@{$xp->{_BaseStack}});
  $xp->base($base);
}

1;

__END__

=head1 NAME

XML::Parser - A perl module for parsing XML documents

=head1 SYNOPSIS

  use XML::Parser;
  
  $p1 = new XML::Parser(Style => 'Debug');
  $p1->parsefile('REC-xml-19980210.xml');
  $p1->parse('<foo id="me">Hello World</foo>');

  # Alternative
  $p2 = new XML::Parser(Handlers => {Start => \&handle_start,
                                     End   => \&handle_end,
                                     Char  => \&handle_char});
  $p2->parse($socket);

  # Another alternative
  $p3 = new XML::Parser(ErrorContext => 2);

  $p3->setHandlers(Char    => \&text,
                   Default => \&other);

  open(FOO, 'xmlgenerator |');
  $p3->parse(*FOO, ProtocolEncoding => 'ISO-8859-1');
  close(FOO);

  $p3->parsefile('junk.xml', ErrorContext => 3);

=begin man
.ds PI PI

=end man

=head1 DESCRIPTION

This module provides ways to parse XML documents. It is built on top of
L<XML::Parser::Expat>, which is a lower level interface to James Clark's
expat library. Each call to one of the parsing methods creates a new
instance of XML::Parser::Expat which is then used to parse the document.
Expat options may be provided when the XML::Parser object is created.
These options are then passed on to the Expat object on each parse call.
They can also be given as extra arguments to the parse methods, in which
case they override options given at XML::Parser creation time.

The behavior of the parser is controlled either by C<L</Style>> and/or
C<L</Handlers>> options, or by L</setHandlers> method. These all provide
mechanisms for XML::Parser to set the handlers needed by XML::Parser::Expat.
If neither C<Style> nor C<Handlers> are specified, then parsing just
checks the document for being well-formed.

When underlying handlers get called, they receive as their first parameter
the I<Expat> object, not the Parser object.

=head1 METHODS

=over 4

=item new

This is a class method, the constructor for XML::Parser. Options are passed
as keyword value pairs. Recognized options are:

=over 4

=item * Style

This option provides an easy way to create a given style of parser. The
built in styles are: L<"Debug">, L<"Subs">, L<"Tree">, L<"Objects">,
and L<"Stream">. These are all defined in separate packages under
C<XML::Parser::Style::*>, and you can find further documentation for
each style both below, and in those packages.

Custom styles can be provided by giving a full package name containing
at least one '::'. This package should then have subs defined for each
handler it wishes to have installed. See L<"STYLES"> below
for a discussion of each built in style.

=item * Handlers

When provided, this option should be an anonymous hash containing as
keys the type of handler and as values a sub reference to handle that
type of event. All the handlers get passed as their 1st parameter the
instance of expat that is parsing the document. Further details on
handlers can be found in L<"HANDLERS">. Any handler set here
overrides the corresponding handler set with the Style option.

=item * Pkg