File Coverage

blib/lib/TBX/Checker.pm

Criterion	Covered	Total	%
statement	65	71	91.5
branch	10	18	55.5
condition	2	5	40.0
subroutine	14	15	93.3
pod	1	1	100.0
total	92	110	83.6

#
# This file is part of TBX-Checker
#
# This software is copyright (c) 2013 by Alan K. Melby.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package TBX::Checker;
use strict;
use warnings;
use autodie;
use File::ShareDir 'dist_dir';
use Exporter::Easy (
	OK => [ qw(check) ],
);
use Path::Tiny;
use Carp;
use feature 'state';
use Capture::Tiny 'capture_merged';
our $VERSION = '0.03'; # VERSION

my $TBXCHECKER = path( dist_dir('TBX-Checker'),'tbxcheck-1_2_9.jar' );

# ABSTRACT: Check TBX validity using TBXChecker

#When run as a script instead of used as a module: check the input file and print the results
_run(@ARGV) unless caller;
sub _run {
	my ($tbx) = @_;
	my ($passed, $messages) = check($tbx);
	($passed && print 'ok!')
		or print join (qq{\n}, @$messages);
	return;
}


sub check {
	my ($data, @args) = @_;

    croak 'missing data argument. Usage: TBX::Checker::check($data, %args)'
        unless $data;

    my $file = _get_file($data);
    #due to TBXChecker bug, file must be relative to cwd
    my $rel_file = $file->relative;
    my $arg_string = _get_arg_string(@args);

    my $command = qq{java -cp ".;$TBXCHECKER" org.ttt.salt.Main } .
        qq{$arg_string "$rel_file"};

	# capture STDOUT and STDERR from jar call into $output
	my $output = capture_merged {system($command)};
	my @messages = split /\v+/, $output;
	my $valid = _is_valid(\@messages);
	return ($valid, \@messages);
}

# get a Path::Tiny object for the file to give to the TBXChecker
sub _get_file {
    my ($data) = @_;
    my $file;
    #pointers are string data
    if(ref $data eq 'SCALAR'){
        $file = Path::Tiny->tempfile;
        #TODO: will this get encodings right?
        $file->append_raw($$data);
    #everything else should be string paths
    }else{
        $file = path($data);
        croak "$file doesn't exist!"
            unless $file->exists;
    }
    return $file;
}

# process arguments and return the command to be run and the file
# being processed (so temp files aren't destroyed by leaving scope)
sub _get_arg_string {
	my (%args) = @_;

	# check the parameters.
    # TODO: use a module or something for param checking
    state $allowed_params = [ qw(
        loglevel lang country variant system version environment) ];
	state $allowed_levels = [ qw(
		OFF SEVERE WARNING INFO CONFIG FINE FINER FINEST ALL) ];
    foreach my $param (keys %args){
        croak "unknown paramter: $param"
            unless grep { $_ eq $param } @$allowed_params;
    }
	if(exists $args{loglevel}){
		grep { $_ eq $args{loglevel} } @$allowed_levels
			or croak "Loglevel doesn't exist: $args{loglevel}";
	}
	$args{loglevel} ||= q{OFF};

	#combine the options into a string that TBXChecker will understand
	return join q{ }, map {"--$_=$args{$_}"} keys %args;
}

#return a boolean indicating the validity of the file, given the messages
#remove the message indicating that the file is valid (if it exists)
sub _is_valid {
	my ($messages) = @_;
	#locate index of "Valid file:" message
	my $index = 0;
	while($index < @$messages){
		last if $$messages[$index] =~ /^Valid file: /;
		$index++;
	}
	#if message not found, file was invalid
	if($index > $#$messages){
		return 0;
	}
	#remove message and return true
	splice(@$messages, $index, 1);
	return 1;
}

1;

__END__