lire 2:2.1.1-2.1 / usr / share / perl5 / Lire / XMLParser.pm

package Lire::XMLParser;

use strict;

use Lire::Error qw/file_not_readable/;
use Lire::Utils qw/check_param/;
use XML::Parser;

=pod

=head1 NAME

Lire::XMLParser - Base object-oriented XML parser.

=head1 SYNOPSIS

    package MyParser;

    use base qw/ Lire::XMLParser /;


=head1 DESCRIPTION

This module makes it possible to write object-oriented parser using
the non-oo XML::Parser module.

=cut

sub new {
    return bless { '_xml_collectors' => {},
                   '_xml_stacks' => {},
                 }, shift;
}

sub Init {
    my $expat = $_[0];
    my $self = $expat->{'_LireXMLParser'};

    $self->{'_xml_expat'} = $expat;
    $self->_build_ns_maps();
    $self->_build_dtd();
    $self->parse_start();

    return;
}

sub Start {
    my ( $expat, $name, %attr ) = @_;

    my $self = $expat->{'_LireXMLParser'};
    my $element = $self->_prefixed_name( $name );
    $self->error( "encountered unknown element '$element'" )
      unless exists $self->{'_xml_elements'}{$element};

    my $parent = $self->current_element();
    $self->error( "'$element' element cannot appear in the context of '$parent'" )
      unless ( ! defined $parent 
               || exists $self->{'_xml_elements'}{$parent}{'content'}{$element} );

    $self->element_start( $element, \%attr );

    return;
}

sub Char {
    my ( $expat, $text ) = @_;

    my $self = $expat->{'_LireXMLParser'};
    my $element = $self->current_element();

    if ( $self->{'_xml_elements'}{$element}{'content'}{'PCDATA'} ) {
        $self->pcdata( $text );
    } elsif ( $text =~ /^\s*$/ ) {
        $self->ignorable_ws( $text );
    } else {
        $self->error( "non-white space character in element '$element' which cannot contain PCDATA" );
    }
    return;
}

sub End {
    my ( $expat, $name ) = @_;

    my $self = $expat->{'_LireXMLParser'};
    my $element = $self->_prefixed_name( $name );
    $self->element_end( $element );

    return;
}


sub Final {
    my $expat = $_[0];
    my $self = $expat->{'_LireXMLParser'};

    delete $self->{'_xml_expat'};
    return $self->parse_end();
}

sub _build_ns_maps {
    my $self = $_[0];

    my $map = $self->namespaces();
    $self->{'_xml_prefix2ns'} = {};
    $self->{'_xml_ns2prefix'} = {};
    while ( my ( $ns, $prefix ) = each %{$map} ) {
        die "missing prefix for namespace '$ns'\n"
          unless defined $prefix && length $prefix;

        die "invalid prefix for namespace '$ns': '$prefix'\n"
          unless  $prefix =~ /[a-zA-Z][-.a-zA-Z0-9]+/;

        die "prefix '$prefix' already used by namespace '$self->{'_xml_prefix2ns'}{$prefix}'\n"
          if exists $self->{'_xml_prefix2ns'}{$prefix};
        $self->{'_xml_prefix2ns'}{$prefix} = $ns;
        $self->{'_xml_ns2prefix'}{$ns} = $prefix;
    }

    return;
}

sub _build_dtd {
    my $self = $_[0];

    $self->{'_xml_elements'} = {};
    my $elements_spec = $self->elements_spec();
    while ( my ( $elmnt, $spec ) = each %{$elements_spec} ) {
        $spec = { 'content' => $spec }
          if ref $spec eq 'ARRAY';
        my ( $prefix, $name ) = _parse_xml_name( $elmnt );
        die "prefix '$prefix' isn't defined by namespaces()\n"
          if $prefix && ! exists $self->{'_xml_prefix2ns'}{$prefix};
        my $ns = $prefix ? $self->{'_xml_prefix2ns'}{$prefix} : '';

        $self->{'_xml_elements'}{$elmnt} = { 'content' => {},
                                             'start' => undef,
                                             'end' => undef,
                                             'char' => undef,
                                             'expat_name' => $self->{'_xml_expat'}->generate_ns_name( $name, $ns )
                                           };
        $spec->{'content'} ||= [];
        foreach my $ok ( @{$spec->{'content'}} ) {
            die "element '$ok' used in content of '$elmnt' isn't defined by elements_spec()\n"
              unless exists $elements_spec->{$ok} || $ok eq 'PCDATA';
            $self->{'_xml_elements'}{$elmnt}{'content'}{$ok} = 1;
        }
        $self->{'_xml_elements'}{$elmnt}{'start'} =
          $self->_find_handler( $spec->{'start'},
                                _default_handler_name( $name, '_start' ) );
        $self->{'_xml_elements'}{$elmnt}{'end'} =
          $self->_find_handler( $spec->{'end'},
                                _default_handler_name( $name, '_end' ) );
        $self->{'_xml_elements'}{$elmnt}{'char'} =
          $self->_find_handler( $spec->{'char'},
                                _default_handler_name( $name, '_char' ) )
            if exists $self->{'_xml_elements'}{$elmnt}{'content'}{'PCDATA'};
    }

    return;
}

sub _find_handler {
    my ( $self, $spec, $default ) = @_;

    if (  $spec ) {
        return $spec if ref $spec eq 'CODE';
        my $handler = $self->can( $spec );
        die "no handler '$spec' defined in ", ref $self, "\n"
          unless $handler;
        return $handler;
    } else {
        return $self->can( $default );
    }
}

sub _prefixed_name {
    my ( $self, $name ) = @_;

    return undef unless defined $name;

    my $ns = $self->{'_xml_expat'}->namespace( $name );
    return $name unless $ns;

    die "namespace '$ns' wasn't defined by namespaces\n"
      unless exists $self->{'_xml_ns2prefix'}{$ns};
    return $self->{'_xml_ns2prefix'}{$ns} . ":" . $name;
}

sub _parse_xml_name {
    return $_[0] =~ /^(?:([a-zA-Z][-.a-zA-Z0-9]+):)?([a-zA-Z][-.a-zA-Z0-9]+)$/;
}

sub _default_handler_name {
    my ( $name, $suffix ) = @_;
    $name =~ tr/a-zA-Z0-9_/_/cs;
    return $name . $suffix;
}

=pod

=head1 CLIENT METHODS

=head2 parse( $xml )

Parse the XML and returns the result. $xml can either be a string or a
reference to an open filehandle or IO::Handle object.

=cut

sub parse {
    my ( $self, $xml ) = @_;

    check_param( $xml, 'xml' );

    my $parser = new XML::Parser( 'Handlers' => { 'Init'  => \&Init,
                                                  'Final' => \&Final,
                                                  'Start' => \&Start,
                                                  'End'   => \&End,
                                                  'Char'  => \&Char,
                                                },
                                  'Namespaces' => 1,
                                  'NoLWP' => 1,
                                );
    $parser->{'_LireXMLParser'} = $self;

    return $parser->parse( $xml );
}

=pod

=head2 parsefile( $file )

Parses the XML contained in $file and returns the result.

=cut

sub parsefile {
    my ( $self, $file ) = @_;

    check_param( $file, 'file' );

    open my $fh, $file
      or die file_not_readable( $file );

    return $self->parse( $fh );
}

=pod

=head1 META-INFORMATION TEMPLATE METHODS

Two template methods must be implemented by subclasses. These methods
gives information on the content model of the XML expected by the
parser.

=head2 namespaces()

This method should return an hash reference. The keys are XML
namespaces understood by the parser. The value is the prefix which is
used for that namespace in the elements_spec() method.

=cut

sub namespaces {
    die 'Unimplemented ', ref $_[0], "::namespaces() method\n";
}

=pod

=head2 elements_spec()

This method should return an hash reference. The key are the known XML
elements. An error will be thrown by the parser when an element not
defined in this hash is encountered.

The key should be of the form [ I<prefix> : ] I<element_name>. If
prefix is used it should be defined in the namespaces() method.

The value of the hash are element specification. This specification
can be used to configure the event handlers that will be called as
well as specifying the content model of the elements. This
specification is an hash reference with the following keys:

=over 4

=item content

This is an array reference that should contains the name of the
elements allowed to appear in that element. These names are in the
same format than for the elements_spec() keys. If that element is
omitted, the element is considered to be empty and thus cannot
contains any other element. If the element can contain PCDATA, the
string 'PCDATA' should be listed in the array.

=item start

This specify the handler called when the opening tag for this element
is encountered. This can be either a function reference or a method
name. If this element is omitted, the handler will be the method named
I<element>_end if it exists, or no handler otherwise. '_' is
substituted for invalid method name characters, i.e. report-spec
becomes report_spec_start.

=item end

This specify the handler called when the closing tag for this element
is encountered. This can be either a function reference or a method
name. If this element is omitted, the handler will be the method named
I<element>_end if it exists, or no handler otherwise. '_' is
substituted for invalid method name characters, i.e. report-spec
becomes report_spec_end.

=item char

This specify the handler called when PCDATA is encountered within the
element. This can only happen if 'PCDATA' appeared in the 'content'
attribute. This can be either a function reference or a method name.
If this element is omitted, the handler will be the method named
I<element>_char if it exists, or no handler otherwise. '_' is
substituted for invalid method name characters, i.e. list-item becomes
list_item_char.

=back

The specification can also be an array reference, in that case it will
be interpreted as the content of the 'content' hash attribute.

Errors will be reported for invalid specification.

=cut

sub elements_spec {
    die 'Unimplemented ', ref $_[0], "::element_specs\n";
}

=pod

=head1 UTILITY METHODS

=head2 expat()

During the parse, this returns the underlying Lire::XMLParser::Expat
parser object.

=cut

sub expat {
    return $_[0]{'_xml_expat'};
}

=pod

=head2 error( $msg )

Will terminate parsing with error message $msg. The current parsing
context will be appended to the message.

=cut

sub error {
    $_[0]{'_xml_expat'}->xpcroak( $_[1] );
    return;
}

=pod

=head2 warning( $msg )

Will print a warning message $msg. The current parsing
context will be appended to the message.

=cut

sub warning {
    $_[0]{'_xml_expat'}->xpcarp( $_[1] );
    return;
}

=pod

=head2 context()

Returns as an array reference the names of the currently opened
elements. In start and end tag, the last element will be the tag of
the parent element. The name of the elements will be in the same
format than the one used by elements_spec().

=cut

sub context {
    return [ map { $_[0]->_prefixed_name( $_ ) }
             $_[0]{'_xml_expat'}->context() ];
}

=pod

=head2 current_element()

Returns the name of the innermost currently opened element. In start
and end tag, the last element will be the tag of the parent element.
The name of the elements will be in the same format than the one used
by elements_spec().

=cut

sub current_element {
    return $_[0]->_prefixed_name( $_[0]{'_xml_expat'}->current_element() );
}

=pod

=head2 in_element( $element_name )

This returns true if the innermost currently opened element has the
same name as $element_name. $element_name should be one of the
elements defined by elements_spec(), otherwise the method will croak.

Example:

    if ( $self->in_element( "lire:report") ) {
        # Parent element is a Lire report element.
    } elsif ( $self->in_element( "listitem" ) ) {
        # We are in a DocBook listitem element
    }

=cut

sub in_element {
    my ( $self, $name ) = @_;

    check_param( $name, 'name' );

    $self->error( "no element '$name' defined by elements_spec()" )
      unless exists $self->{'_xml_elements'}{$name};

    return $self->{'_xml_expat'}->in_element( $self->{'_xml_elements'}{$name}{'expat_name'} );
}

=pod

=head2 within_element( $element_name )

This returns the number of times an element is opened in the current
element ancestor. Like for the in_element(), the element's name should
have been defined by elements_spec(), otherwise the method will croak.

=cut

sub within_element {
    my ( $self, $name ) = @_;

    check_param( $name, 'name' );

    $self->error( "no element '$name' defined by elements_spec()" )
      unless exists $self->{'_xml_elements'}{$name};

    return $self->{'_xml_expat'}->within_element( $self->{'_xml_elements'}{$name}{'expat_name'} );
}

=pod

=head2 recognized_string()

Returns the string that trigger the current event.

=cut

sub recognized_string {
    return $_[0]{'_xml_expat'}->recognized_string();
}

=pod

=head2 depth()

Returns the number of opened and not yet closed elements. In start and
end handlers, the current elemnt is part of that list.

=cut

sub depth {
    return $_[0]{'_xml_expat'}->depth();
}

=pod

=head1 EVENT HANDLERS METHODS

These are methods that are called during the XML parsing.

=cut

=pod

=head2 parse_start()

This methods is invoked once before the document is parsed. It can be
used for any initialization the processor has to do. Default
implementation does nothing.

=cut

sub parse_start {}

=pod

=head2 parse_end( )

This methods is invoked once after all the XML file was processed. The
value that this method returns will be returned by the parse() or
parsefile() method (whichever was used to start the parsing). Default
implementation does nothing.

=cut

sub parse_end {}

=pod

=head2 element_start( $name, $attributes )

Called when a valid element is opened. $name contains the name of the
element. This name is the canonical form, that is that if the element
is within a namespace, it will be prefixed with the prefix declared by
the namespaces() method. $attributes contains the defined attributes
in an hash reference.

The default method will dispatch to the handlers defined by
elements_spec().

=cut

sub element_start {
    my ( $self, $name, $attributes ) = @_;

    my $handler = $self->{'_xml_elements'}{$name}{'start'};
    $handler->( $self, $name, $attributes )
      if $handler;

    return;
}

=pod

=head2 element_end( $name )

Called when a valid element is closed. $name contains the name of the
element. Default implementation dispatch to the handler defined by
elements_spec().

=cut

sub element_end {
    my ( $self, $name ) = @_;

    my $handler = $self->{'_xml_elements'}{$name}{'end'};
    $handler->( $self, $name )
      if $handler;

    return;
}

=pod

=head2 pcdata( $text )

Called when parsed character data are encountered in an element which
is allowed to contain PCDATA. Default implementation dispatch to the
handler defined by elements_spec().

=cut

sub pcdata {
    my ( $self, $text ) = @_;

    my $name = $self->current_element();
    my $handler = $self->{'_xml_elements'}{$name}{'char'};
    $handler->( $self, $text )
      if $handler;


    return;
}

=pod

=head2 ignorable_ws( $ws )

Called when whitespace is encountered while processing an element
which cannot contain PCDATA. Default implementation does nothing. This
is mainly used by parser which want to keep the user's format.

=cut

sub ignorable_ws {
    my ( $self, $ws ) = @_;

    return;
}


=pod

=head1 HELPERS METHODS

Two common tasks when writing event-based parsers is to use "stacks"
and "collectors". The XMLParser object offers some method to manage
these common objects.

=head2 init_collector( $name )

This initialize a collector with the name $name. If there was already
a collector defined under this name, its content will be reset to the
empty string ''.

=cut

sub init_collector {
    my ( $self, $name ) = @_;

    check_param( $name, 'name' );

    $self->{'_xml_collectors'}{$name} = '';

    return;
}

=pod

=head2 collect( $name, $text )

Appends $text to the collector $name. An exception will be thrown if
no collector $name was previously defined.

=cut

sub collect {
    my ( $self, $name, $text ) = @_;

    check_param( $name, 'name' );
    check_param( $text, 'text' );

    $self->error( "no collector '$name' defined" )
      unless exists $self->{'_xml_collectors'}{$name};

    $self->{'_xml_collectors'}{$name} .= $text;

    return;
}

=pod

=head2 get_collector( $name )

Returns the content accumulated in the collector $name. An exception
will be thrown if no collector $name was previously defined.

=cut

sub get_collector {
    my ( $self, $name ) = @_;

    check_param( $name, 'name' );

    $self->error( "no collector '$name' defined" )
      unless exists $self->{'_xml_collectors'}{$name};

    return $self->{'_xml_collectors'}{$name};
}

=pod

=head2 collector_start( $element, $attributes )

This is a method which can be used as a start event handler. It will
define a collector with the same name than the element which is
started.

=cut

sub collector_start {
    my ( $self, $element, $attributes ) = @_;

    $self->init_collector( $element );

    return;
}

=pod

=head2 collector_char( $text )

This is a method which can be used as a char event handler. It will
append $text to the collector named under the element in which this
text occurs.

=cut

sub collector_char {
    my ( $self, $text ) = @_;

    $self->collect( $self->current_element(), $text );

    return;
}

=pod

=head2 init_stack( $name )

Initialize a stack object named $name.

=cut

sub init_stack {
    my ( $self, $name ) = @_;

    check_param( $name, 'name' );

    $self->{'_xml_stacks'}{$name} = [];

    return;
}

=pod

=head2 stack_push( $name, $value )

Returns true if the stack $name is empty. An exception will be raise
if no stack $name was defined.

=cut

sub is_stack_empty {
    my ( $self, $name ) = @_;

    check_param( $name, 'name' );

    $self->error( "no stack '$name' defined" )
      unless exists $self->{'_xml_stacks'}{$name};

    return @{$self->{'_xml_stacks'}{$name}} == 0;
}

=pod 

=head2 stack_depth( $name )

Returns the number of element on the stack $name. An
exception will be raise if no stack $name was defined.

=cut

sub stack_depth {
    my ( $self, $name ) = @_;

    check_param( $name, 'name' );

    $self->error( "no stack '$name' defined" )
      unless exists $self->{'_xml_stacks'}{$name};

    return scalar @{$self->{'_xml_stacks'}{$name}};
}

=pod

=head2 stack_push( $name, $value )

Pushes $value onto the stack $name. An exception will be raise if no
stack $name was defined.

=cut

sub stack_push {
    my ( $self, $name, $value ) = @_;

    check_param( $name, 'name' );

    $self->error( "no stack '$name' defined" )
      unless exists $self->{'_xml_stacks'}{$name};

    push @{$self->{'_xml_stacks'}{$name}}, $value;

    return;
}

=pod

=head2 stack_pop( $name )

Removes and returns the top value on the stack $name. An exception
will be raised if no stack $name was defined or if the stack is empty.

=cut

sub stack_pop {
    my ( $self, $name ) = @_;

    check_param( $name, 'name' );

    $self->error( "no stack '$name' defined" )
      unless exists $self->{'_xml_stacks'}{$name};

    $self->error( "stack '$name' is empty" )
      unless @{$self->{'_xml_stacks'}{$name}};

    return pop @{$self->{'_xml_stacks'}{$name}};
}

=pod

=head2 stack_peek( $name )

Returns the top value of the stack $name. An exception will be raised if
no stack $name was defined or if the stack is empty.

=cut

sub stack_peek {
    my ( $self, $name ) = @_;

    check_param( $name, 'name' );

    $self->error( "no stack '$name' defined" )
      unless exists $self->{'_xml_stacks'}{$name};

    $self->error( "stack '$name' is empty" )
      unless @{$self->{'_xml_stacks'}{$name}};

    return ${$self->{'_xml_stacks'}{$name}}[-1];
}

1;

__END__

=pod

=head1 SEE ALSO

 Lire::Config::SpecParser(3pm), Lire::ReportParser(3pm),
 Lire::XMLSpecContainer(3pm)

=head1 AUTHOR

  Francis J. Lacoste <flacoste@logreport.org>

=head1 VERSION

$Id: XMLParser.pm,v 1.11 2006/07/23 13:16:30 vanbaal Exp $

=head1 COPYRIGHT

Copyright (C) 2004 Stichting LogReport Foundation LogReport@LogReport.org

This file is part of Lire.

Lire is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program (see COPYING); if not, check with
http://www.gnu.org/copyleft/gpl.html.

=cut