File Coverage

blib/lib/XML/Liberal.pm

Criterion	Covered	Total	%
statement	22	65	33.8
branch	1	22	4.5
condition	1	4	25.0
subroutine	7	17	41.1
pod	2	6	33.3
total	33	114	28.9

package XML::Liberal;

use strict;
use 5.008_001;
our $VERSION = '0.30';

use base qw( Class::Accessor );
use Carp;
use UNIVERSAL::require;
use Module::Pluggable::Fast
    name => 'remedies',
    search => [ 'XML::Liberal::Remedy' ],
    require => 1;

__PACKAGE__->remedies(); # load remedies now
__PACKAGE__->mk_accessors(qw( max_fallback guess_encodings ));

our $Debug;

sub debug {
    my $self = shift;
    $self->{debug} = shift if @_;
    $self->{debug} || $XML::Liberal::Debug;
}

sub new {
    my $class = shift;
    my $driver = shift || 'LibXML';

    my $subclass = "XML::Liberal::$driver";
       $subclass->require or die $@;

    my %param = @_;
    $param{max_fallback} = 15 unless defined $param{max_fallback};

    $subclass->new(%param);
}

sub globally_override {
    my $class = shift;
    my $driver = shift || 'LibXML';

    my $subclass = "XML::Liberal::$driver";
       $subclass->require or die $@;

    $subclass->globally_override;

    if (defined wantarray) {
        return XML::Liberal::Destructor->new(
            sub { $subclass->globally_unoverride },
        );
    }

    return;
}

sub parse_string {
    my $self = shift;
    my($xml) = @_;

  TRY:
    for (1 .. $self->max_fallback) {
        my $doc = eval { $self->{parser}->parse_string($xml) };
        return $doc if $doc;

        my $error = $self->extract_error($@, \$xml);
        for my $remedy (sort $self->remedies) {
            warn "considering $remedy\n" if $self->debug;
            $remedy->apply($self, $error, \$xml) or next;
            warn "--- remedy applied: $xml\n" if $self->debug;
            next TRY;
        }

        # We've considered all possible remedies for this error, and none
        # worked, so just throw an exception.
        Carp::croak($error->summary);
    }
}

sub parse_file {
    my($self, $file) = @_;
    open my $fh, "<", $file or croak "$file: $!";
    $self->parse_fh($fh);
}

sub parse_fh {
    my($self, $fh) = @_;
    my $xml = join '', <$fh>;
    $self->parse_string($xml);
}

our $AUTOLOAD;
sub AUTOLOAD {
    my($self, @args) = @_;
    (my $meth = $AUTOLOAD) =~ s/.*:://;
    $self->{parser}->$meth(@args);
}

sub DESTROY {
    my $self = shift;
    delete $self->{parser};
}

package XML::Liberal::Destructor;

sub new {
    my($class, $callback) = @_;
    bless { cb => $callback }, $class;
}

sub DESTROY {
    my $self = shift;
    $self->{cb}->();
}

package XML::Liberal;

1;
__END__