File Coverage

lib/XML/Schema/Parser.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

#============================================================= -*-perl-*-
#
# XML::Schema::Parser
#
# DESCRIPTION
#   XML parser module which is bound to a particular Schema and/or
#   Schedule.
#
# AUTHOR
#   Andy Wardley
#
# COPYRIGHT
#   Copyright (C) 2001 Canon Research Centre Europe Ltd.
#   All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
# REVISION
#   $Id: Parser.pm,v 1.1.1.1 2001/08/29 14:30:17 abw Exp $
#
#========================================================================

package XML::Schema::Parser;

use strict;
use XML::Parser;
use XML::Schema::Base;
use base qw( XML::Schema::Base );
use vars qw( $VERSION $DEBUG $ERROR $ETYPE @OPTIONAL $XML_PARSER_ARGS );

$VERSION = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
$DEBUG   = 0 unless defined $DEBUG;
$ERROR   = '';
$ETYPE   = 'parser';

@OPTIONAL = qw( schema );

$XML_PARSER_ARGS = {
    ErrorContext  => 2,
    Namespaces    => 1,
    ParseParamEnt => 1,
};


#------------------------------------------------------------------------
# init(\%config)
#
# Called by new() constructor method to initialise object.
#------------------------------------------------------------------------

sub init {
    my ($self, $config) = @_;
    my ($opt) = @{ $self->_baseargs( qw( @OPTIONAL ) ) };

    $self->_optional($opt, $config)
	|| return;

    return $self;
}


#------------------------------------------------------------------------
# schema($schema)
#
# Retrieve current schema or update with new reference provided.
#------------------------------------------------------------------------

sub schema {
    my $self = shift;
    return @_ ? ($self->{ schema } = shift)
	      :  $self->{ schema };
}


#------------------------------------------------------------------------
# parsefile($file)
#
# Parse XML file.
#------------------------------------------------------------------------

sub parsefile {
    my ($self, $file) = @_;
    my $parser = $self->parser()
	|| return;
    my $result;
    eval {
	$result = $parser->parsefile($file);
    };
    if (my $error = $@) {
	$error =~ s/\s*at \S+ line \d+\s*$//s;
	return $self->error($error);
    }
    return $result;
}


#------------------------------------------------------------------------
# parse($text)
#
# Parse XML text.
#------------------------------------------------------------------------

sub parse {
    my ($self, $text) = @_;
    my $parser = $self->parser()
	|| return;
    my $result;
    eval {
	$result = $parser->parse($text);
    };
    if (my $error = $@) {
	$error =~ s/\s*at \S+ line \d+\s*$//s;
	return $self->error($error);
    }
    return $result;
}


#------------------------------------------------------------------------
# parser($schema, \%args)
#
# Return underlying XML::Parser instance (possibly cached) properly
# configured for action.
#------------------------------------------------------------------------

sub parser {
    my $self = shift;
    my $schema = shift
	|| $self->{ schema }
	|| return $self->error('no schema');
    my $args = $_[0] && ref($_[0]) eq 'HASH' ? shift : { @_ };

    my $instance = $schema->instance($args)
	|| return $self->error( $schema->error() );

    my $handlers = $instance->expat_handlers()
	|| return $self->error( $schema->error() );

    # handlers can be returned as { Init => ..., etc } or as
    # { Style => ..., Handlers => { Init => ..., etc } }; we
    # convert the former to the latter and supply instance class
    # as the default Style (i.e. recipient of parse events)

    $handlers = {
	Style    => ref $instance,
	Handlers => $handlers,
    }
    unless $handlers->{ Handlers };

    my $xpargs = {
	%$XML_PARSER_ARGS,
	map { defined $args->{$_} ? ( $_, $args->{$_} ) : ( ) }
	keys %$XML_PARSER_ARGS
    };
    return XML::Parser->new(
	%$xpargs,
	%$handlers,
    );
}

1;

__END__