The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# base class.
package Driver::Sablotron;

use Driver::BaseClass;
@ISA = qw(Driver::BaseClass);

use XML::Sablotron;
use IO::File;

use vars qw(
        $xslt
        $stylesheet
        $input
        $handler
        );

sub init {
    my %options = @_;
    $xslt = XML::Sablotron->new();
    $handler = Driver::Sablotron::Handler->new(%options);
    $xslt->RegHandler(0, $handler);
}

sub shutdown {
    $xslt->ClearError();
    $xslt->UnregHandler(0, $handler);
    undef $handler;
    undef $xslt;
    undef $input;
    undef $stylesheet;
}

sub load_stylesheet {
    my ($filename) = @_;
    my $fh = new IO::File;
    if ($fh->open("< $filename")) {
        local $/;        
        $stylesheet = <$fh>;
        $fh->close;
    }
}

sub load_input {
    my ($filename) = @_;
    my $fh = new IO::File;   
    if ($fh->open("< $filename")) { 
        local $/; 
        $input = <$fh>;   
        $fh->close;       
    }    
}

use Cwd;

sub run_transform {
    my ($output) = @_;
    $handler->{show_error} = 1;
    open(OUT, ">$output")
            || die "Can't write $output : $!";

    my $result = '';
    my $args = ['template', "$stylesheet", 'xml_resource', "$input"];

    my $retcode = $xslt->RunProcessor("arg:/template", "arg:/xml_resource", "arg:/result",                                                [], $args);
    $result = $xslt->GetResultArg("result");

    print OUT $result;
    close OUT;
}

package Driver::Sablotron::Handler;

sub new {
    my $class = shift;
    my %options = @_;
    bless \%options, $class;
}

sub MHMakeCode {
    my $self = shift;
    my $processor = shift;

    my ($severity, $facility, $code) = @_;
    return $code;
}

sub MHLog {
    return 1;
}

sub MHError {
    my $self = shift;
    my $processor = shift;
    my ($code, $level, @fields) = @_;
    
    return unless $self->{show_error};
    $self->{show_error} = 0;
    
    warn "Sablotron [Error]: ", join(' :: ', @fields), "\n" if $self->{verbose};
    return 1;
}

1;