package XML::Checker::Parser;

use strict;

use XML::Parser;

use XML::Checker;

use vars qw( @ISA @InterceptedHandlers @SGML_SEARCH_PATH %URI_MAP

	     $_checker $_prevFAIL

	     $_Init $_Final $_Char $_Start $_End $_Element $_Attlist 

	     $_Doctype $_Unparsed $_Notation $_Entity $_skipInsignifWS

	     $_EndOfDoc

	   );

@ISA = qw( XML::Parser );

@InterceptedHandlers = qw( Init Final Char Start End Element Attlist 

			   Doctype Unparsed Notation Entity );

# Where to search for external DTDs (in local file system)

@SGML_SEARCH_PATH = ();

# Where to search for external DTDs as referred to by public ID in a 

# <!DOCTYPE ...> statement, e.g. "-//W3C//DTD HTML 4.0//EN"

# E.g. it could map "-//W3C//DTD HTML 4.0//EN" to "file:/user/html.dtd"

%URI_MAP = ();

sub new

{

    my ($class, %args) = @_;

    my $super = new XML::Parser (%args);

    $super->{Checker} = new XML::Checker (%args);

    my %handlers = %{$super->{Handlers}};

    # Don't need Comment handler - assuming comments are allowed anywhere

#?? What should Default handler do?

#?? Check XMLDecl, ExternEnt, Proc?  No, for now.

#?? Add CdataStart, CdataEnd support?

    for (@InterceptedHandlers)

    {

	my $func = "XML::Checker::Parser::$_";

	$handlers{$_} = \&$func;

    }

    $super->{UserHandlers} = $super->{Handlers};

    $super->{Handlers} = \%handlers;

    bless $super, $class;

}

sub getChecker

{

    $_[0]->{Checker}

}

sub parse

{

    my $self = shift;

    my $uh = $self->{UserHandlers};

    local $_checker = $self->{Checker};

    local $_Init = $uh->{Init};

    local $_Final = $uh->{Final};

    local $_Start = $uh->{Start};

    local $_End = $uh->{End};

    local $_Char = $uh->{Char};

    local $_Element = $uh->{'Element'};

    local $_Attlist = $uh->{'Attlist'};

    local $_Doctype = $uh->{Doctype};

    local $_Unparsed = $uh->{Unparsed};

    local $_Notation = $uh->{Notation};

    local $_Entity = $uh->{Entity};

    local $_prevFAIL = $XML::Checker::FAIL;

    local $XML::Checker::FAIL = \&fail_add_context;

    local $XML::Checker::INSIGNIF_WS = 0;

    local $_skipInsignifWS = $self->{SkipInsignifWS};

    local $_EndOfDoc = 0;

    $self->SUPER::parse (@_);

}

my $LWP_USER_AGENT;

sub set_LWP_UserAgent	# static

{

    $LWP_USER_AGENT = shift;

}

sub load_URL		# static

{

    my ($url, $lwp_user_agent) = @_;

    my $result;

    # Read the file from the web with LWP.

    #

    # Note that we read in the entire file, which may not be ideal

    # for large files. LWP::UserAgent also provides a callback style

    # request, which we could convert to a stream with a fork()...

    my $response;

    eval

    {

	use LWP::UserAgent;

	my $ua = $lwp_user_agent;

	unless (defined $ua)

	{

	    unless (defined $LWP_USER_AGENT)

	    {

		$LWP_USER_AGENT = LWP::UserAgent->new;

		# Load proxy settings from environment variables, i.e.:

		# http_proxy, ftp_proxy, no_proxy etc. (see LWP::UserAgent(3))

		# You need these to go thru firewalls.

		$LWP_USER_AGENT->env_proxy;

	    }

	    $ua = $LWP_USER_AGENT;

	}

	my $req = new HTTP::Request 'GET', $url;

	$response = $LWP_USER_AGENT->request ($req);

	$result = $response->content;

    };

    if ($@)

    {

	die "Couldn't load URL [$url] with LWP: $@";

    }

    if (!$result)

    {

	my $message = $response->as_string;

	die "Couldn't load URL [$url] with LWP: $message";

    }

    return $result;

}

sub parsefile

{

    my $self = shift;

    my $url = shift;

    # Any other URL schemes?

    if ($url =~ /^(https?|ftp|wais|gopher|file):/)

    {

	my $xml = load_URL ($url, $self->{LWP_UserAgent});

	my $result;

	eval

	{

	    # Parse the result of the HTTP request

	    $result = $self->parse ($xml, @_);

	};

	if ($@)

	{

	    die "Couldn't parsefile [$url]: $@";

	}

	return $result;

    }

    else

    {

	return $self->SUPER::parsefile ($url, @_);

    }

}

sub Init

{

    my $expat = shift;

    $_checker->{Expat} = $expat;

    $_checker->Init (@_);

    &$_Init ($expat) if $_Init;

}

sub Final

{

    my $expat = shift;

    $_EndOfDoc = 1;

    $_checker->Final (@_);

    my $result = &$_Final ($expat) if $_Final;

    # Decouple Expat from Checker

    delete $_checker->{Expat};

    # NOTE: Checker is not decoupled

    return $result;

}

sub Start

{

    my ($expat, $tag, @attr) = @_;

    $_checker->Start ($tag);

    my $num_spec = $expat->specified_attr;

    for (my $i = 0; $i < @attr; $i++)

    {

	my $spec = ($i < $num_spec);

	my $attr = $attr[$i];

	my $val = $attr[++$i];

#	print "--- $tag $attr $val $spec\n";

	$_checker->Attr ($tag, $attr, $val, $spec);

    }

    $_checker->EndAttr;

    &$_Start ($expat, $tag, @attr) if $_Start;

}

sub End

{

    my $expat = shift;

    $_checker->End (@_);

    &$_End ($expat, @_) if $_End;

}

sub Char

{

    my $expat = shift;

    $_checker->Char (@_);

    &$_Char ($expat, @_) 

	if $_Char && !($XML::Checker::INSIGNIF_WS && $_skipInsignifWS);

    # Skip insignificant whitespace

}

sub Element

{

    my $expat = shift;

    $_checker->Element (@_);

    &$_Element ($expat, @_) if $_Element;

}

sub Attlist

{

    my $expat = shift;

    $_checker->Attlist (@_);

    &$_Attlist ($expat, @_) if $_Attlist;

}

sub Doctype

{

    my $expat = shift;

    my ($name, $sysid, $pubid, $internal) = @_;

    my $dtd;

    unless ($_checker->{SkipExternalDTD}) 

    {

	if ($sysid)

	{

	    # External DTD...

	    #?? I'm not sure if we should die here or keep going?	    

	    $dtd = load_DTD ($sysid, $expat->{LWP_UserAgent});

	}

	elsif ($pubid)

	{

	    $dtd = load_DTD ($pubid, $expat->{LWP_UserAgent});

	}

    }

    if (defined $dtd)

    {

#?? what about passing ProtocolEncoding, Namespaces, Stream_Delimiter ?

	my $parser = new XML::Parser (

	    Checker => $_checker, 

	    ErrorContext => $expat->{ErrorContext},

	    Handlers => { 

		Entity => \&XML::Checker::Parser::ExternalDTD::Entity,

		Notation => \&XML::Checker::Parser::ExternalDTD::Notation,

		Element => \&XML::Checker::Parser::ExternalDTD::Element,

		Attlist => \&XML::Checker::Parser::ExternalDTD::Attlist,

		Unparsed => \&XML::Checker::Parser::ExternalDTD::Unparsed,

	    });

	eval 

	{

	    $parser->parse ("<!DOCTYPE $name SYSTEM '$sysid' [\n$dtd\n]>\n<$name/>");

	};

	if ($@)

	{

	    die "Couldn't parse contents of external DTD <$sysid> :$@";

	}

    }

    $_checker->Doctype (@_);

    &$_Doctype ($expat, @_) if $_Doctype;

}

sub Unparsed

{

    my $expat = shift;

    $_checker->Unparsed (@_);

    &$_Unparsed ($expat, @_) if $_Unparsed;

}

sub Entity

{

    my $expat = shift;

    $_checker->Entity (@_);

    &$_Entity ($expat, @_) if $_Entity;

}

sub Notation

{

    my $expat = shift;

    $_checker->Notation (@_);

    &$_Notation ($expat, @_) if $_Notation;

}

sub Default

{

#?? what can I check here?

#    print "Default handler got[" . join (", ", @_) . "]";

}

#sub XMLDecl

#{

#?? support later?

#}

sub setHandlers

{

    my ($self, %h) = @_;

    for my $name (@InterceptedHandlers)

    {

	if (exists $h{$name})

	{

	    eval "\$_$name = \$h{$name}";

	    delete $h{$name};

	}

    }

    # Pass remaining handlers to the parent class (XML::Parser)

    $self->SUPER::setHandlers (%h);

}

# Add (line, column, byte) to error context (unless it's EOF)

sub fail_add_context	# static

{

    my $e = $_checker->{Expat};

    my $byte = $e->current_byte;	# -1 means: end of XML document

    if ($byte != -1 && !$_EndOfDoc)

    {

	push @_, (line => $e->current_line, 

		  column => $e->current_column, 

		  byte => $byte);

    }

    &$_prevFAIL (@_);

}

#-------- STATIC METHODS related to External DTDs ---------------------------

sub load_DTD		# static

{

    my ($sysid, $lwp_user_agent) = @_;

    # See if it is defined in the %URI_MAP

    # (Public IDs are stored here, e.g. "-//W3C//DTD HTML 4.0//EN")

    if (exists $URI_MAP{$sysid})

    {

	$sysid = $URI_MAP{$sysid};

    }

    elsif ($sysid !~ /^\w+:/) 

    {

	# Prefix the sysid with 'file:' if it has no protocol identifier

	unless ($sysid =~ /^\//) 

	{

	    # Not an absolute path. See if it's in SGML_SEARCH_PATH.

	    my $relative_sysid = $sysid;

	    $sysid = find_in_sgml_search_path ($sysid);

	    if (! $sysid) 

	    {

		if ($ENV{'SGML_SEARCH_PATH'}) 

		{

		    die "Couldn't find external DTD [$relative_sysid] in SGML_SEARCH_PATH ($ENV{'SGML_SEARCH_PATH'})";

		}

		else 

		{

		    die "Couldn't find external DTD [$relative_sysid], may be you should set SGML_SEARCH_PATH";

		}

	    }

	}

	$sysid = "file:$sysid";

    }

    return load_URL ($sysid, $lwp_user_agent);

}

sub map_uri			# static

{

    %URI_MAP = (%URI_MAP, @_);

}

sub set_sgml_search_path	# static

{

    @SGML_SEARCH_PATH = @_;

}

sub find_in_sgml_search_path	# static

{

    my $file = shift;

    my @dirs = @SGML_SEARCH_PATH;

    unless (@dirs)

    {

	my $path = $ENV{SGML_SEARCH_PATH};

	if ($path)

	{

	    @dirs = split (':', $path);

	}

	else

	{

	    my $home = $ENV{HOME};

	    @dirs = (".", "$home/.sgml", "/usr/lib/sgml", "/usr/share/sgml");

	}

    }

    for my $directory (@dirs) 

    {

	if (-e "$directory/$file") 

	{

	    return "$directory/$file";

	}

    }

    return undef;

}

package XML::Checker::Parser::ExternalDTD;

sub Element {

	my $expat = shift;

	$expat->{Checker}->Element(@_);

}

sub Attlist {

	my $expat = shift;

	$expat->{Checker}->Attlist(@_);

}

sub Unparsed {

	my $expat = shift;

	$expat->{Checker}->Unparsed(@_);

}

sub Notation {

	my $expat = shift;

	$expat->{Checker}->Notation(@_);

}

sub Entity {

	my $expat = shift;

#	print "Entity: $expat\n";

	$expat->{Checker}->Entity(@_);

}

1; # package return code

__END__

=head1 NAME

XML::Checker::Parser - an XML::Parser that validates at parse time

=head1 SYNOPSIS

 use XML::Checker::Parser;

 my %expat_options = (KeepCDATA => 1, 

		      Handlers => [ Unparsed => \&my_Unparsed_handler ]);

 my $parser = new XML::Checker::Parser (%expat_options);

 eval {

     local $XML::Checker::FAIL = \&my_fail;

     $parser->parsefile ("fail.xml");

 };

 if ($@) {

     # Either XML::Parser (expat) threw an exception or my_fail() died.

     ... your error handling code here ...

 }

 # Throws an exception (with die) when an error is encountered, this

 # will stop the parsing process.

 # Don't die if a warning or info message is encountered, just print a message.

 sub my_fail {

     my $code = shift;

     die XML::Checker::error_string ($code, @_) if $code < 200;

     XML::Checker::print_error ($code, @_);

 }

=head1 DESCRIPTION

XML::Checker::Parser extends L<XML::Parser>

I hope the example in the SYNOPSIS says it all, just use 

L<XML::Checker::Parser> as if it were an XML::Parser. 

See L<XML::Parser> for the supported (expat) options.

You can also derive your parser from XML::Checker::Parser instead of 

from XML::Parser. All you should have to do is replace:

 package MyParser;

 @ISA = qw( XML::Parser );

with:

 package MyParser;

 @ISA = qw( XML::Checker::Parser );

=head1 XML::Checker::Parser constructor

 $parser = new XML::Checker::Parser (SkipExternalDTD => 1, SkipInsignifWS => 1);

The constructor takes the same parameters as L<XML::Parser> with the following additions:

=over 4

=item SkipExternalDTD

By default, it will try to load external DTDs using LWP. You can disable this

by setting SkipExternalDTD to 1. See L<External DTDs|"External DTDs"> for details.

=item SkipInsignifWS

By default, it will treat insignificant whitespace as regular Char data.