File Coverage

blib/lib/Test/Formats/XML.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

###############################################################################
#
# This file copyright (c) 2008 by Randy J. Ray, all rights reserved.
#
# See LICENSE in the documentation for redistribution terms.
#
###############################################################################
#
#   $Id: XML.pm 9 2008-10-22 09:28:28Z rjray $
#
#   Description:
#
#   Functions:      is_valid_against
#                   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
#
#   Libraries:      Test::Builder::Module
#                   XML::LibXML
#
#   Global Consts:  $VERSION
#
###############################################################################

package Test::Formats::XML;

use 5.008;
use strict;
use warnings;
use subs qw(is_valid_against
            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);
use base 'Test::Builder::Module';

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);

our $VERSION = '0.12';

###############################################################################
#
#   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.
#
#   Arguments:      NAME        IN/OUT  TYPE    DESCRIPTION
#                   $document   in      varies  The XML content to validate--
#                                                 may be a string, filehandle,
#                                                 etc.
#                   $schema     in      ref     An object from one of the
#                                                 ::Dtd, ::Schema or ::RelaxNG
#                                                 validator classes
#                   $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 ($document, $schema, $name) = @_;
    my $TESTBUILDER = __PACKAGE__->builder;
    my $is_valid = 0;
    my $dom;

    # If there was some sort of parse-level error creating the validator
    # object, we'll have gotten undef for $schema. We could put this test
    # in each of the three type-specific functions, but the test itself is
    # identical so it might as well just be here:
    if (! defined($schema))
    {
        return $TESTBUILDER->ok(0, $name) || $TESTBUILDER->diag($@);
    }

    # 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
        eval { $dom = $parser->parse_fh($document); };
    }
    elsif (ref($document) eq 'XML::LibXML::Document')
    {
        # This one is a gimme... if they were kind-enough to pre-parse it
        $dom = $document;
    }
    elsif (ref($document) eq 'SCALAR')
    {
        # A scalar-ref is presumed to be the XML text passed by reference
        eval { $dom = $parser->parse_string($$document); };
    }
    elsif ($document =~ /<\?xml|
    {
        # If the text looks like XML (has either a declarative PI or a DOCTYPE
        # declaration), assume that it is directly-passed-in XML content
        eval { $dom = $parser->parse_string($document); };
    }
    else
    {
        # Failing any of the previous tests, assume that it is a filename
        eval { $dom = $parser->parse_file($document); };
    }

    # Skip the actual testing if whichever parser-call above ended up being
    # called set an exception in $@:
    unless ($@)
    {
        # 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...
            eval { $dom->validate($schema); };
        }
        elsif ($schema->isa('XML::LibXML::RelaxNG') or
               $schema->isa('XML::LibXML::Schema'))
        {
            eval { $schema->validate($dom); };
        }
        else
        {
            # Might be over-loading the use of this function, so I can't be
            # certain that it won't get called with something in $schema that
            # doesn't match either of the above tests.
            $TESTBUILDER->ok(0, $name);
            $TESTBUILDER->
                diag("Argument '$schema' not valid for is_valid_against()");
            return 0;
        }

        # If validation failed, $@ was set with some explanation. We'll use it
        # below in a chain-call that includes diag(), but what matters here is
        # setting $is_valid to a true value if $@ is *not* set.
        $is_valid = ($@) ? 0 : 1;
    }

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

###############################################################################
#
#   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
#                   $document   in      varies  The document/text to test
#                   $schema     in      varies  The schema (RelaxNG) to test
#                                                 $document against
#                   $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 ($document, $schema, $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
        eval {
            $dom_schema =
                XML::LibXML::RelaxNG->new(string => join('', <$schema>));
        };
    }
    elsif ($schema =~ /<(?:[\w\.]+:)?grammar/ or
           $schema =~ m|http://relaxng\.org/ns/structure/1\.0| or
           $schema =~ m|http://relaxng\.org/ns/annotation/1\.0|)
    {
        # It appears to be a schema contained in the string/scalar... attempt
        # to parse it
        eval { $dom_schema = XML::LibXML::RelaxNG->new(string => $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
        eval { $dom_schema = XML::LibXML::RelaxNG->new(string => $$schema); };
    }
    elsif (! ref($schema))
    {
        # If it isn't a reference but didn't match the pattern above, try using
        # it as a file-name
        eval { $dom_schema = XML::LibXML::RelaxNG->new(location => $schema); };
    }
    else
    {
        # Can't figure out what it's supposed to be, so just fail the test
        # with a hopefully-helpful diagnostic
        return $TESTBUILDER->ok(0, $name) ||
            $TESTBUILDER->diag("Cannot deduce how to turn '$schema' into a " .
                               'XML::LibXML::RelaxNG instance');
    }

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

# Semantic-sugar alias 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
#                   $document   in      varies  The document/text to test
#                   $schema     in      varies  The schema (XML Schema) to test
#                                                 $document against
#                   $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 ($document, $schema, $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
        eval {
            $dom_schema =
                XML::LibXML::Schema->new(string => join('', <$schema>));
        };
    }
    elsif ($schema =~ /<(?:[\w\.]+:)?schema/ or
           $schema =~ m|http://www\.w3\.org/2001/XMLSchema|)
    {
        # It appears to be a schema contained in the string/scalar... attempt
        # to parse it
        eval { $dom_schema = XML::LibXML::Schema->new(string => $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
        eval { $dom_schema = XML::LibXML::Schema->new(string => $$schema); };
    }
    elsif (! ref($schema))
    {
        # If it isn't a reference but didn't match the pattern above, try using
        # it as a file-name
        eval { $dom_schema = XML::LibXML::Schema->new(location => $schema); };
    }
    else
    {
        # Can't figure out what it's supposed to be, so just fail the test
        # with a hopefully-helpful diagnostic
        return $TESTBUILDER->ok(0, $name) ||
            $TESTBUILDER->diag("Cannot deduce how to turn '$schema' into a " .
                               'XML::LibXML::Schema instance');
    }

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

# Semantic-sugar alias 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
#                   $document   in      varies  The document/text to test
#                   $schema     in      varies  The schema (SGML DTD) to test
#                                                 $document against
#                   $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 ($document, $schema, $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
        eval {
            $dom_schema = XML::LibXML::Dtd->parse_string(join('', <$schema>));
        };
    }
    elsif ($schema =~ /!ENTITY|!ELEMENT|!ATTLIST/)
    {
        # It appears to be a DTD contained in the string/scalar... attempt to
        # parse it
        eval { $dom_schema = XML::LibXML::Dtd->parse_string($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
        eval { $dom_schema = XML::LibXML::Dtd->parse_string($$schema); };
    }
    elsif (! ref($schema))
    {
        # If it isn't a reference but didn't match the pattern above, try using
        # it as a file-name
        eval { $dom_schema = XML::LibXML::Dtd->new('', $schema); };
    }
    else
    {
        # Can't figure out what it's supposed to be, so just fail the test
        # with a hopefully-helpful diagnostic
        return $TESTBUILDER->ok(0, $name) ||
            $TESTBUILDER->diag("Cannot deduce how to turn '$schema' into a " .
                               'XML::LibXML::Dtd instance');
    }

    is_valid_against($document, $dom_schema, $name);
}
# Semantic-sugar alias 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) = @_;
    my $TESTBUILDER = __PACKAGE__->builder;
    my $is_valid = 0;
    my $dom;

    # Try to parse $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
        eval { $dom = $parser->parse_fh($document); };
    }
    elsif (ref($document) eq 'SCALAR')
    {
        # A scalar-ref is presumed to be the XML text passed by reference
        eval { $dom = $parser->parse_string($$document); };
    }
    elsif ($document =~ /<\?xml|
    {
        # If the text looks like XML (has either a declarative PI or a DOCTYPE
        # declaration), assume that it is directly-passed-in XML content
        eval { $dom = $parser->parse_string($document); };
    }
    else
    {
        # Failing any of the previous tests, assume that it is a filename
        eval { $dom = $parser->parse_file($document); };
    }

    $TESTBUILDER->ok(($@) ? 0 : 1, $name) || $TESTBUILDER->diag($@);
}
# Semantic-sugar alias for the above:
*xml_parses_ok = \&is_well_formed_xml;

1;

__END__