#!/usr/bin/env perl
use strict;

use Getopt::Std qw(getopts);
use XML::Xerces;


sub usage {
    my $usage = qq{
        Usage: $0 [-h] [-s schema] [-v] [file1.xml [file2.xml ...]]
        Options:
           -h        : show this help message
           -s schema : specify a schema filename or URL to validate against
           -v        : enable verbose messages
           fileN.xml : list of XML files to validate (default stdin)
    };
    for ($usage) { s/^\s+//s; s/\s+$//s; s/^\s{8}//mg; }
    print STDERR "$usage\n";
    exit(shift) if @_;
}

getopts('hs:v', \our %Opts) || usage(1);
usage(0) if $Opts{h};

$::schema = $Opts{s};
$::verbose = $Opts{v};

XML::Xerces::XMLPlatformUtils::Initialize();

my $parser = XML::Xerces::SAXParser->new;
$parser->setDoNamespaces(1);
$parser->setDoSchema(1);
$parser->setValidationSchemaFullChecking(1);
$parser->setValidationScheme(1);
$parser->setExitOnFirstFatalError(0);
$parser->setValidationConstraintFatal(0);
$parser->cacheGrammarFromParse(1);
$parser->useCachedGrammarInParse(1);

my $eh = ValidatorErrorHandler->new;
$parser->setErrorHandler($eh);

my @files = @ARGV;
push @files, '-' if !@files;

my $perfect = 1;

for my $filename (@files) {
    my $document;
    if ($filename eq '-') {
        $document = do { local $/; <STDIN> };
    }
    else {
        $document = do { local (@ARGV,$/) = ($filename); <> };
    }

    if ($::schema) {
        my ($xsd,$namespace) = reverse split(/\s+/s, $::schema, 2);

        if (!$namespace) {
            my ($first_tag) = ($document =~ /(<\w[^>]*>)/);
            if ($first_tag =~ /\bxmlns="([^"]+)"/) {
                $namespace = $1;
            }
            elsif ($first_tag =~ /^<([^:]+):/) {
                my $ns_abbr = $1;
                if ($first_tag =~ /\b\Q$ns_abbr\E:xmlns="([^"]+)"/) {
                    $namespace = $1;
                }
            }
        }

        if ($xsd && $namespace) {
            $parser->setExternalSchemaLocation("$namespace $xsd");
        }
        else {
            $parser->setExternalNoNamespaceSchemaLocation($xsd);
        }
    }

    my $friendly_fn = $filename eq '-' ? 'stdin' : $filename;
    
    my $input = XML::Xerces::MemBufInputSource->new($document, $friendly_fn);
    $parser->parse($input);

    if ($eh->is_perfect) {
        say(sprintf("%s: no errors", $friendly_fn));
    }
    else {
        $perfect = 0;
        say( sprintf("%s: %d warnings, %d errors", $friendly_fn,
            scalar(@{$eh->warnings}), scalar(@{$eh->errors})));
    }
}

exit($perfect ? 0 : 1);


END {
    XML::Xerces::XMLPlatformUtils::Terminate();
}

sub say {
    my $msg = shift;
    print STDERR "$msg\n" if $::verbose;
}


{
    package ValidatorErrorHandler;
    no warnings 'uninitialized';
    
    sub new {
        my $class = shift;
        return bless {}, $class; 
    }

    sub emit {
        my ($self,$err,$type) = @_;

        my $system_id = $err->getSystemId;
        my $line_num  = $err->getLineNumber;
        my $col_num   = $err->getColumnNumber;
        my $msg       = $err->getMessage;

        my $is_fatal = 1
            if $msg =~ /The primary document entity could not be opened./;

        my $has_af = eval { require Text::Autoformat };
        $msg = $has_af ? Text::Autoformat::autoformat("    $msg") : $msg;

        $msg = sprintf "\n%s: %s [line %d, col %d]:\n%s",
            $type, $system_id, $line_num, $col_num, $msg;

        if ($is_fatal) {
            # stop processing
            die $msg;
        }
        else {
            print STDERR $msg;
        }
    }
    
    sub warning {
        my ($self,$err) = @_;
        $self->emit($err, 'WARNING');
        
        push @{$self->warnings}, $err;
    }
    
    sub error {
        my ($self,$err) = @_;
        $self->emit($err, 'ERROR');
        
        push @{$self->errors}, $err;
    }

    sub fatal_error { &error }

    sub is_perfect {
        my ($self) = @_;
        my $n = @{$self->warnings} + @{$self->errors};
        return $n == 0;
    }
    
    sub warnings {
        my $self = shift;
        my $warnings = $self->{_warnings} ||= [];
        return $warnings;
    }
    
    sub errors {
        my $self = shift;
        my $errors = $self->{_errors} ||= [];
        return $errors;
    }

    sub reset_errors {
        my $self = shift;
        delete $self->{_warnings};
        delete $self->{_errors};
    }
}

1;