File Coverage

blib/lib/PITA/XML.pm

Criterion	Covered	Total	%
statement	102	120	85.0
branch	23	40	57.5
condition	7	15	46.6
subroutine	32	34	94.1
pod	0	1	0.0
total	164	210	78.1

package PITA::XML;

# See POD at end for docs.

use 5.006;
use strict;
use Carp                    ();
use Params::Util            ();
use IO::File                ();
use IO::String              ();
BEGIN {
	# Temporary Hack:
	# IO::String looks like a duck and quacks liks a duck, but we need it
	# to be a real duck. So lets make it a duck (if it didn't turn into a
	# real duck while we weren't looking.)
	unless ( @IO::String::ISA ) {
		@IO::String::ISA = qw{ IO::Handle IO::Seekable };
	}
}
use File::ShareDir          ();
use XML::SAX::ParserFactory ();

# Optionally load the schema validator
BEGIN {
	local $@;
	eval {
		require XML::Validator::Schema;
	};
}

use vars qw{$VERSION};
BEGIN {
	$VERSION = '0.52';
}

# The XML Schema File
# Locate the Schema at use-time (instead of compile-time) and
# allow the specification of a custom schema.
use vars qw{$SCHEMA};
$SCHEMA ||= File::ShareDir::dist_file('PITA-XML', 'pita-xml.xsd');

# While in development, use a version-specific namespace.
# In theory, this ensures documents are only truly valid with the
# version they were created with.
use constant XMLNS => "http://ali.as/xml/schema/pita-xml/$VERSION";

# The list of core schemes
use vars qw{%SCHEMES};
BEGIN {
	%SCHEMES = (
		'perl5'       => 1,
		'perl5.make'  => 1,
		'perl5.build' => 1,
		'perl6'       => 1,
	);
}

# Load the various classes
use PITA::XML::Storable  ();
use PITA::XML::Command   ();
use PITA::XML::Test      ();
use PITA::XML::Request   ();
use PITA::XML::Platform  ();
use PITA::XML::File      ();
use PITA::XML::Guest     ();
use PITA::XML::Install   ();
use PITA::XML::Report    ();
use PITA::XML::SAXParser ();
use PITA::XML::SAXDriver ();





#####################################################################
# Main Methods

sub validate {
	my $class = shift;
	my $fh    = $class->_FH(shift);

	# Make schema validation dependant on module availability
	$XML::Validator::Schema::VERSION or return 1;

	# Create the validator
	my $parser = XML::SAX::ParserFactory->parser(
		Handler => XML::Validator::Schema->new(
			file => $SCHEMA,
		),
	);

	# Validate the document
	$parser->parse_file( $fh );

	1;
}




#####################################################################
# Support Methods

sub _FH {
	my $class = shift;
	my $file  = shift;
	if ( Params::Util::_SCALAR($file) ) {
		$file = IO::String->new( $file );
	}
	if ( Params::Util::_INSTANCE($file, 'IO::Handle') ) {
		if ( $file->can('seek') ) {
			# Reset the file handle
			$file->seek( 0, 0 ) or Carp::croak(
				'Failed to reset file handle (seek to 0)',
			);
			return $file;
		}
		Carp::croak('IO::Handle is not seekable');
	}
	unless ( defined $file and ! ref $file and length $file ) {
		Carp::croak('Did not provide a file name or handle');
	}
	unless ( $file and -f $file and -r _ ) {
		Carp::croak('Did not provide a readable file name');
	}
	my $fh = IO::File->new( $file );
	unless ( $fh ) {
		 Carp::croak("Failed to open PITA::XML file '$file'");
	}
	$fh;
}

sub _OUTPUT {
	my ($class, $object, $name) = @_;

	# If provided as a param, clean it up
	if ( exists $object->{$name} ) {
		# Convert from array to scalar ref
		if ( Params::Util::_ARRAY0($object->{$name}) ) {
			# Clean up newlines and merge into SCALAR
			my $param = $object->{$name};
			foreach my $i ( 0 .. $#$param ) {
				$param->[$i] =~ s/[\012\015]+$/\n/;
			}
			$param = join '', @$param;
			$object->{$name} = \$param;
		}
	}

	# Check for scalarness
	Params::Util::_SCALAR0($object->$name()) ? 1 : undef;
}

sub _SCHEME {
	my $class  = shift;
	my $string = Params::Util::_STRING(shift) or return undef;
	($SCHEMES{$string} or $string =~ /x_/) ? $string : undef;
}

sub _MD5SUM {
	my $class  = shift;
	my $md5sum = Params::Util::_STRING(shift) or return undef;
	($md5sum =~ /^[0-9a-f]{32}$/i) ? lc($md5sum) : undef;
}

sub _DISTNAME {
	my $class    = shift;
	my $distname = Params::Util::_STRING(shift) or return undef;
	($distname =~ /^[a-z]\w*(?:\-[a-z]\w*)+$/is) ? $distname : undef;
}

sub _GUID {
	my $class = shift;
	my $guid  = Params::Util::_STRING(shift) or return undef;
	($guid =~ /^[0-9A-F]{8}-[0-9A-F]{4}-[0-9A-F]{4}-[0-9A-F]{4}-[0-9A-F]{12}$/) ? $guid : undef;
}

1;

__END__