File Coverage

blib/lib/Test/AgainstSchema/XML.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

###############################################################################
#
# This file copyright (c) 2011 by Randy J. Ray, all rights reserved.
#
###############################################################################
#
#   Description:    A "specialization" of Test::AgainstSchema that handles XML
#                   data. Can test for XML to be valid against RelaxNG, DTD or
#                   XML Schema. Can also simply test for well-formedness.
#
#   Functions:      is_valid_against
#                   is_valid_against_relaxng
#                   is_valid_against_xmlschema
#                   is_valid_against_sgmldtd
#                   is_well_formed_xml
#
#   Libraries:      Test::Builder::Module
#                   XML::LibXML
#                   Try::Tiny
#
#   Global Consts:  $VERSION
#
###############################################################################

package Test::AgainstSchema::XML;

use 5.008;
use strict;
use warnings;
use vars qw($VERSION);
use subs qw(is_valid_against is_valid_against_relaxng
            is_valid_against_xmlschema is_valid_against_sgmldtd
            is_well_formed_xml);
use base 'Test::Builder::Module';

use Try::Tiny;
use XML::LibXML;

our @EXPORT = qw(is_valid_against_relaxng   is_valid_against_rng  relaxng_ok
                 is_valid_against_xmlschema is_valid_against_xsd  xmlschema_ok
                 is_valid_against_sgmldtd   is_valid_against_dtd  sgmldtd_ok
                 is_well_formed_xml         xml_parses_ok);

$VERSION = '0.100';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)

###############################################################################
#
#   Sub Name:       is_valid_against
#
#   Description:    This is the back-end that all of the other test routines
#                   actually use. It assumes that the first argument has
#                   already been converted to a XML::LibXML::{Dtd,Schema,etc.}
#                   object at this point, but the derivation of whether the
#                   target argument is a string, file, etc. is centralized
#                   here. If $schema is null/undef, then we were called from
#                   is_well_formed_xml(), and we are only testing the parsing
#                   of $document, not its validity.
#
#   Arguments:      NAME        IN/OUT  TYPE    DESCRIPTION
#                   $schema     in      ref     An object from one of the
#                                                 ::Dtd, ::Schema or ::RelaxNG
#                                                 validator classes
#                   $document   in      varies  The XML content to validate--
#                                                 may be a string, filehandle,
#                                                 etc.
#                   $name       in      scalar  If passed, this is the "name"
#                                                 for the test, the text that
#                                                 is printed in the TAP stream
#
#   Returns:        The return value of $TESTBUILDER->ok()
#
###############################################################################
sub is_valid_against
{
    my ($schema, $document, $name) = @_;
    my $TESTBUILDER = __PACKAGE__->builder;
    my $is_valid = 0;
    my $dom;

    # Try to get a DOM object out of $document, by hook or by crook:
    my $parser = XML::LibXML->new();
    if ($TESTBUILDER->is_fh($document))
    {
        # Anything that looks like a file-handle gets treated as such
        try {
            $dom = $parser->parse_fh($document);
            $is_valid = 1;
        } catch {
            $dom = $_;
        };
    }
    elsif (ref($document) eq 'XML::LibXML::Document')
    {
        # This one is a gimme... they were kind-enough to pre-parse it
        $dom = $document;
        $is_valid = 1;
    }
    elsif (ref($document) eq 'SCALAR')
    {
        # A scalar-ref is presumed to be the XML text passed by reference
        try {
            $dom = $parser->parse_string(${$document});
            $is_valid = 1;
        } catch {
            $dom = $_;
        };
    }
    elsif ($document =~ m{
                            # Processing instruction:
                            <[?]xml
                        |
                            # Document type declaration:

                        |
                            # Reasonable approximation of a tag:
                            <[:_\p{IsAlphabetic}][-:.\w]
                     }x)
    {
        # If the text looks like XML (has either a declarative PI, a DOCTYPE
        # declaration or something that looks enough like a tag), assume that
        # it is directly-passed-in XML content
        try {
            $dom = $parser->parse_string($document);
            $is_valid = 1;
        } catch {
            $dom = $_;
        };
    }
    else
    {
        # Failing any of the previous tests, assume that it is a filename
        try {
            $dom = $parser->parse_file($document);
            $is_valid = 1;
        } catch {
            $dom = $_;
        };
    }

    # Skip the actual testing if whichever parser-call above ended up being
    # called set an exception in $dom (signified by $is_valid being false).
    # Also, if $schema is undef that means that we were only testing the XML
    # itself, so there is no need for this block.
    if ($is_valid && $schema)
    {
        # The XML::LibXML::Schema and XML::LibXML::RelaxNG classes are both
        # validators, and have the same interface for the part I care about--
        # a method validate() that takes a DOM object (the result of a parse)
        # and dies if the document doesn't validate. Alas, the XML::LibXML::Dtd
        # class *doesn't* follow this convention, so I have to special case
        # it.
        if ($schema->isa('XML::LibXML::Dtd'))
        {
            # If we have a DTD-derived object, we use the validate() method
            # on the $dom value itself and pass the compiled DTD as an
            # argument. The other two do this the other way around...
            try {
                $dom->validate($schema);
            } catch {
                $dom = $_;
                $is_valid = 0;
            };
        }
        else
        {
            try {
                $schema->validate($dom);
            } catch {
                $dom = $_;
                $is_valid = 0;
            };
        }
    }

    # Whatever we ended up with as "$is_valid" is what ok() gets to use
    return $TESTBUILDER->ok($is_valid, $name) || $TESTBUILDER->diag($dom);
}

###############################################################################
#
#   Sub Name:       is_valid_against_relaxng
#
#   Description:    Test the input against a RelaxNG schema. The first argument
#                   is either a compiled XML::LibXML::RelaxNG object, the text
#                   of a schema or a filename. Convert the argument to a
#                   compiled schema object (if necessary) and filter through
#                   to is_valid_against() with the other arguments. We leave
#                   the evaluation/normalization of the $document argument for
#                   that routine, since that part is common to all of these
#                   type-specific tester-routines.
#
#   Arguments:      NAME        IN/OUT  TYPE    DESCRIPTION
#                   $schema     in      varies  The schema (RelaxNG) to test
#                                                 $document against
#                   $document   in      varies  The document/text to test
#                   $name       in      scalar  If passed, the "name" or label
#                                                 for the test in the TAP
#                                                 output stream
#
#   Returns:        return value from is_valid_against()
#
###############################################################################
sub is_valid_against_relaxng
{
    my ($schema, $document, $name) = @_;
    my $TESTBUILDER = __PACKAGE__->builder;
    my $dom_schema;

    if (ref($schema) eq 'XML::LibXML::RelaxNG')
    {
        # They passed in an already-compiled object
        $dom_schema = $schema;
    }
    elsif ($TESTBUILDER->is_fh($schema))
    {
        # The XML::LibXML::RelaxNG class cannot currently parse directly from a
        # filehandle, so try calling new(string => ...) on the join'd contents
        # of the handle
        my $code = do { local $/ = undef; <$schema> };
        try {
            $dom_schema = XML::LibXML::RelaxNG->new(string => $code);
        } catch {
            $dom_schema = $_;
        };
    }
    elsif ($schema =~ m{http://relaxng[.]org/ns/structure/1[.]0} or
               $schema =~ /<(?:[\w.]+:)?grammar/)
    {
        # It appears to be a schema contained in the string/scalar... attempt
        # to parse it
        try {
            $dom_schema = XML::LibXML::RelaxNG->new(string => $schema);
        } catch {
            $dom_schema = $_;
        };
    }
    elsif (ref($schema) eq 'SCALAR')
    {
        # Assume that a scalar reference is the text of a schema passed in by
        # reference to save stack-space
        try {
            $dom_schema = XML::LibXML::RelaxNG->new(string => ${$schema});
        } catch {
            $dom_schema = $_;
        };
    }
    elsif (! ref $schema)
    {
        # If it isn't a reference but didn't match the pattern above, try using
        # it as a file-name
        try {
            $dom_schema = XML::LibXML::RelaxNG->new(location => $schema);
        } catch {
            $dom_schema = $_;
        };
    }
    else
    {
        # Can't figure out what it's supposed to be, so just set up to fail the
        # test with a hopefully-helpful diagnostic.
        $dom_schema = "Cannot determine how to turn '$schema' into a " .
            'XML::LibXML::RelaxNG instance';
    }

    # If $dom_schema is not a reference, then it is an error message from an
    # attempt to parse (or from the failure clause, above).
    if (! ref $dom_schema)
    {
        $TESTBUILDER->ok(0, $name);
        $TESTBUILDER->diag($dom_schema);
        return 0;
    }

    return is_valid_against($dom_schema, $document, $name);
}

# Semantic-sugar aliases for the above:
*relaxng_ok = *is_valid_against_rng = \&is_valid_against_relaxng;

###############################################################################
#
#   Sub Name:       is_valid_against_xmlschema
#
#   Description:    Test the input against an XML Schema. The first argument
#                   is either a compiled XML::LibXML::Schema object, the text
#                   of a schema or a filename. Convert the argument to a
#                   compiled schema object (if necessary) and filter through
#                   to is_valid_against() with the other arguments. We leave
#                   the evaluation/normalization of the $document argument for
#                   that routine, since that part is common to all of these
#                   type-specific tester-routines.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $schema     in      varies  The schema (XML Schema) to test
#                                                 $document against
#                   $document   in      varies  The document/text to test
#                   $name       in      scalar  If passed, the "name" or label
#                                                 for the test in the TAP
#                                                 output stream
#
#   Returns:        return value from is_valid_against()
#
###############################################################################
sub is_valid_against_xmlschema
{
    my ($schema, $document, $name) = @_;
    my $TESTBUILDER = __PACKAGE__->builder;
    my $dom_schema;

    if (ref($schema) eq 'XML::LibXML::Schema')
    {
        # They passed in an already-compiled object
        $dom_schema = $schema;
    }
    elsif ($TESTBUILDER->is_fh($schema))
    {
        # The XML::LibXML::Schema class cannot currently parse directly from a
        # filehandle, so try calling new(string => ...) on the join'd contents
        # of the handle
        my $code = do { local $/ = undef; <$schema> };
        try {
            $dom_schema = XML::LibXML::Schema->new(string => $code);
        } catch {
            $dom_schema = $_;
        };
    }
    elsif ($schema =~ m{http://www[.]w3[.]org/2001/XMLSchema} or
               $schema =~ /<(?:[\w.]+:)?schema/)
    {
        # It appears to be a schema contained in the string/scalar... attempt
        # to parse it
        try {
            $dom_schema = XML::LibXML::Schema->new(string => $schema);
        } catch {
            $dom_schema = $_;
        };
    }
    elsif (ref($schema) eq 'SCALAR')
    {
        # Assume that a scalar reference is the text of a schema passed in by
        # reference to save stack-space
        try {
            $dom_schema = XML::LibXML::Schema->new(string => ${$schema});
        } catch {
            $dom_schema = $_;
        };
    }
    elsif (! ref $schema)
    {
        # If it isn't a reference but didn't match the pattern above, try using
        # it as a file-name
        try {
            $dom_schema = XML::LibXML::Schema->new(location => $schema);
        } catch {
            $dom_schema = $_;
        };
    }
    else
    {
        # Can't figure out what it's supposed to be, so just set up to fail the
        # test with a hopefully-helpful diagnostic.
        $dom_schema = "Cannot determine how to turn '$schema' into a " .
            'XML::LibXML::Schema instance';
    }

    # If $dom_schema is not a reference, then it is an error message from an
    # attempt to parse (or from the failure clause, above).
    if (! ref $dom_schema)
    {
        $TESTBUILDER->ok(0, $name);
        $TESTBUILDER->diag($dom_schema);
        return 0;
    }

    return is_valid_against($dom_schema, $document, $name);
}

# Semantic-sugar aliases for the above:
*xmlschema_ok = *is_valid_against_xsd = \&is_valid_against_xmlschema;

###############################################################################
#
#   Sub Name:       is_valid_against_sgmldtd
#
#   Description:    Test the input against a SGML DTD. The first argument
#                   is either a compiled XML::LibXML::Dtd object, the text
#                   of a DTD or a filename. Convert the argument to a
#                   compiled object (if necessary) and filter through to
#                   is_valid_against() with the other arguments. We leave
#                   the evaluation/normalization of the $document argument for
#                   that routine, since that part is common to all of these
#                   type-specific tester-routines.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $schema     in      varies  The schema (SGML DTD) to test
#                                                 $document against
#                   $document   in      varies  The document/text to test
#                   $name       in      scalar  If passed, the "name" or label
#                                                 for the test in the TAP
#                                                 output stream
#
#   Returns:        return value from is_valid_against()
#
###############################################################################
sub is_valid_against_sgmldtd
{
    my ($schema, $document, $name) = @_;
    my $TESTBUILDER = __PACKAGE__->builder;
    my $dom_schema;

    if (ref($schema) eq 'XML::LibXML::Dtd')
    {
        # They passed in an already-compiled object
        $dom_schema = $schema;
    }
    elsif ($TESTBUILDER->is_fh($schema))
    {
        # The XML::LibXML::Dtd class cannot currently parse directly from a
        # filehandle, so try calling parse_string() on the join'd contents of
        # the handle
        my $code = do { local $/ = undef; <$schema> };
        try {
            $dom_schema = XML::LibXML::Dtd->parse_string($code);
        } catch {
            $dom_schema = $_;
        };
    }
    elsif ($schema =~ /!ENTITY|!ELEMENT|!ATTLIST/)
    {
        # It appears to be a DTD contained in the string/scalar... attempt to
        # parse it
        try {
            $dom_schema = XML::LibXML::Dtd->parse_string($schema);
        } catch {
            $dom_schema = $_;
        };
    }
    elsif (ref($schema) eq 'SCALAR')
    {
        # Assume that a scalar reference is the text of a DTD passed in by
        # reference to save stack-space
        try {
            $dom_schema = XML::LibXML::Dtd->parse_string(${$schema});
        } catch {
            $dom_schema = $_;
        };
    }
    elsif (! ref $schema)
    {
        # If it isn't a reference but didn't match the pattern above, try using
        # it as a file-name
        try {
            $dom_schema = XML::LibXML::Dtd->new(q{}, $schema);
        } catch {
            $dom_schema = $_;
        };
    }
    else
    {
        # Can't figure out what it's supposed to be, so just set up to fail the
        # test with a hopefully-helpful diagnostic.
        $dom_schema = "Cannot determine how to turn '$schema' into a " .
            'XML::LibXML::Dtd instance';
    }

    # If $dom_schema is not a reference, then it is an error message from an
    # attempt to parse (or from the failure clause, above).
    if (! ref $dom_schema)
    {
        $TESTBUILDER->ok(0, $name);
        $TESTBUILDER->diag($dom_schema);
        return;
    }

    return is_valid_against($dom_schema, $document, $name);
}
# Semantic-sugar aliases for the above:
*sgmldtd_ok = *is_valid_against_dtd = \&is_valid_against_sgmldtd;

###############################################################################
#
#   Sub Name:       is_well_formed_xml
#
#   Description:    Test whether the content passed in parses as XML without
#                   errors. Makes no effort to validate, only parse.
#
#   Arguments:      NAME        IN/OUT  TYPE    DESCRIPTION
#                   $document   in      varies  The document/text to test
#                   $name       in      scalar  If passed, the "name" or label
#                                                 for the test in the TAP
#                                                 output stream
#
#   Returns:        Success:    1
#                   Failure:    0
#
###############################################################################
sub is_well_formed_xml
{
    my ($document, $name) = @_;

    return is_valid_against(undef, $document, $name);
}
# Semantic-sugar alias for the above:
*xml_parses_ok = \&is_well_formed_xml;

1;

__END__