File Coverage

blib/lib/Batch/Interpreter/TestSupport.pm

Criterion	Covered	Total	%
statement	122	135	90.3
branch	33	52	63.4
condition	5	8	62.5
subroutine	20	20	100.0
pod	4	9	44.4
total	184	224	82.1

package Batch::Interpreter::TestSupport;

=head1 NAME

Batch::Interpreter::TestSupport - support code for testing Batch::Interpreter

=head1 SYNOPSIS

The output of runbat is compared with the output of CMD.EXE. On systems with CMD.EXE the batch files can be run with CMD.EXE to store the expected output. The switch --complete combines both steps.

=head1 METHODS

=cut

use v5.10;
use warnings;
use strict;
use parent 'Exporter';
our @EXPORT_OK = qw(
	get_test_attr compare_output
	read_file
);

our $VERSION = 0.01;

use Getopt::Long;
use Test::More;
use Test::Differences;
use Data::Dump qw(dump);
use File::Spec;
use File::Temp;
use Cwd;

=head2 ->get_test_attr()

Read C<@ARGV> to generate a C<$test_attr> HashRef, that is returned for (possibly modified) use in ->compare_output().

=cut
sub get_test_attr {
	my ($record, $compare, $complete);
	my $dump;
	my $verbose;
	my $help;
	GetOptions(
		'record' => \$record,
		'compare' => \$compare,
		'complete' => \$complete,
		'dump' => \$dump,
		'verbose!' => \$verbose,
		'help|h|?!' => \$help,
	);
	if ($help) {
		say <<"EOH";
usage: $0 [--record|--compare|--complete] [--dump] [--[no-]verbose] [--help|-h|-?] [-- ]

	--record
		Run the test script with the system shell and store the	output.
		Only available under Win32.
	--compare
		Run the test script with runbat and compare the output.
		This is the default.
	--complete
		First --record, then --compare.

	--dump	Dump the outputs before comparison.

	--verbose
		Be verbose.

	--help
		This help.
EOH
		exit 1;
	}
	my $mode = $complete ? 'record,compare'
		: $record ? 'record'
		: 'compare';
	return {
		mode => $mode,
		dump => $dump,
		argv => [ @ARGV ],
		verbose => $verbose,
		number => 0,
	};
}

# TODO: use a prepackaged implementation
sub quote_argument {
	$_ = shift;
	s/([\\\"])/\\$1/gi;
	return /[\s\\\"]/ ? "\"$_\"" : $_;
}

# Some archivers may restore test files with the wrong newlines, so ship the
# files in hex and decode before use.
sub decode_file {
	my ($filename) = @_;
	my $hexname = "$filename.hex";
	if (-e $hexname && !-e $filename) {
		open my $in, '<', $hexname or die "$hexname: $!";
		open my $out, '>:raw', $filename or die "$filename: $!";
		local $/;
		print $out pack 'H*', <$in>;
		close $_ for $in, $out;

		# file may need some time to be visible on network filesystems
		while (!-e $filename) {
			say STDERR "Waiting for creation of $filename...";
			sleep 1;
		}
	}
}

=head2 read_file($filename)

Read C<$filename> in the same way as compare_output() reads it (including possible decoding) and return the content as a binary string.
=cut
sub read_file {
	my ($filename) = @_;
	decode_file $filename;
	open my $fh, '<:raw', $filename
		or die "open '$filename': $!";
	local $/;
	return scalar <$fh>;
}


sub filter_log {
	my ($type, $stream, $attr, $content) = @_;

	# system and emulated CMD may have different CWDs (virtual mount
	# points) and they may be differently slashed.
	# the tested program maps t/ to B:/test/, but we have to translate
	# the output of CMD.EXE, where at least the absolute paths are
	# easily matched
	$type eq 'cmd' and
		$content =~
			s([A-Za-z]\:[\\\/][^\:]*\bBatch-Interpreter.*[\\\/]t\b)
			(B:\\test)gm;

	$content =~ s/\r//g
		if $attr->{unix_nl};

	$content = $attr->{filter_log}->($type, $stream, $content)
		if $attr->{filter_log};

	return $content;
}

sub read_content {
	my ($fh) = @_;
	seek $fh, 0, SEEK_SET
		or die $!;
	binmode $fh;
	local $/;
	return scalar <$fh>;
}

sub store_content {
	my ($output, $content) = @_;

	if ('SCALAR' eq ref $output) {
		$$output = $content;
	} else {
		open my $out, '>:raw', $output;
		print $out $content;
	}
}

sub run_redirected {
	my ($type, $attr, @commandline) = @_;
	my $cmd = join ' ', map quote_argument($_), @commandline;

	say STDERR "COMMAND: $cmd"
		if $attr->{verbose};

	my ($old_stdout, $old_stderr);
	my ($stdout, $stderr);
	if ($attr->{stdout}) {
		$stdout = File::Temp->new();
		open $old_stdout, '>&', \*STDOUT;
		open \*STDOUT, '>&', $stdout;
	}
	if ($attr->{stderr}) {
		$stderr = File::Temp->new();
		open $old_stderr, '>&', \*STDERR;
		open \*STDERR, '>&', $stderr;
	}

	system $cmd;

	if ($stderr) {
		open \*STDERR, '>&', $old_stderr;
		store_content $attr->{stderr},
			filter_log $type, 'stderr', $attr,
				read_content $stderr;
	}
	if ($stdout) {
		open \*STDOUT, '>&', $old_stdout;
		store_content $attr->{stdout},
			filter_log $type, 'stdout', $attr,
				read_content $stdout;
	}

	return !($? & 127);
}

=head2 compare_output($test_attr, $subtest_name, @commandline)

Compare the output of running C<@commandline> with CMD.EXE and Batch::Interpreter.

C<$subtest_name> can be given as undef, in which case the subtests are simply numbered.

Attributes that can be added to C<$test_attr> are:

=over

=item verbose

Be verbose.

=item filter_log

A callback CodeRef, that is used to filter the output, which is called as

	$content = $attr->{filter_log}->($type, $stream, $content)

C<$type> can be 'cmd' or 'lib', C<$stream> can be 'stdout' or 'stderr'.

=item unix_nl

Normalize the data to unix newlines before comparison. Note 'before comparison' includes the point in time the CMD.EXE output is saved.

=item skip_stderr

Only STDOUT is compared, not STDERR.

=item in_dir

The command is run in the given directory.

=back

=cut
sub compare_output {
	my ($test_attr, $subtest_name, @commandline) = @_;

	my $runbat = 'bin/runbat';
	my $lib = 'lib';
	my $t = 't';

	my $olddir;
	if ($test_attr->{in_dir}) {
		$_ = File::Spec->rel2abs($_) for $runbat, $lib, $t;

		$olddir = getcwd;
		chdir $test_attr->{in_dir};
	}

	decode_file $_
		for @commandline;

	my $mode = $test_attr->{mode};

	my $basename = (File::Spec->splitpath($0))[2];
	#$basename =~ s/^\d+_//;
	$basename =~ s/\.t$//;

	$subtest_name //= sprintf '%02d', $test_attr->{number}++;

	my $base = join '_', $basename, $subtest_name;
	my $digest = "$base: @commandline";

	my @stream = qw(stdout stderr);
	$test_attr->{skip_stderr}
		and @stream = grep $_ ne 'stderr', @stream;

	my %attr = map +($_ => \(my $data)), @stream;
	my %cmd_attr = map +($_ => "$t/$base.cmd.$_"), @stream;

	if ($mode =~ /\brecord\b/) {
		$^O =~ /Win/ or die "record mode only possible under windows";

		# run with CMD
		my $ok = run_redirected('cmd', { %$test_attr, %cmd_attr },
			map { y/\//\\/; $_ } @commandline
		);
		# suppress tests for complete mode
		if ($mode eq 'record') {
			ok $ok, "record $digest";
			pass "no comparison: $digest";
		}
	}

	if ($mode =~ /\bcompare\b/) {
		ok run_redirected('lib', { %$test_attr, %attr },
			$^X, '-I', $lib,
			$runbat,
			'--mount', "B:/test=$t",
			@{$test_attr->{argv} // []},
			'--',
			@commandline
		), "run $digest";

		my %result = map +($_ => ${$attr{$_}}), @stream;
		my %cmd_result = map +($_ => read_file $cmd_attr{$_}), @stream;

		$test_attr->{dump} and
			dump [\%result, \%cmd_attr, \%cmd_result];

		eq_or_diff $result{$_}, $cmd_result{$_}, "result($_) $digest"
			for @stream;

		unlink @attr{@stream};
	}

	defined $olddir and chdir $olddir;
}

1;

__END__