#: t/Backend/Base.pm
package Test::Make::Base;
#use Smart::Comments;
use Test::Base -Base;
use Test::Make::Util;
use File::Temp qw( tempdir tempfile );
use Cwd ();
use File::Spec ();
use FindBin;
use IPC::Run3;
use Time::HiRes qw( time );
#use Data::Dumper::Simple;
our @EXPORT = qw(
run_test run_tests create_file use_source_ditto
$MAKE $PERL $SHELL $PWD
);
our @EXPORT_BASE = qw(set_make set_shell set_filters);
our ($SHELL, $PERL, $MAKE, $MAKEPATH, $MAKEFILE, $PWD);
our (@MakeExe, %Filters);
our ($UseSourceDitto, $SavedSource);
# default filters for expected values
#filters {
# stdout => [qw< preprocess >],
# stdour_like => [qw< preprocess_like >],
# stderr => [qw< preprocess >],
# stderr_like => [qw< preprocess_like >],
#};
sub set_make ($$) {
my ($env_name, $default) = @_;
$MAKEPATH = $ENV{$env_name} || $default;
$MAKEPATH =~ s,\\,/,g;
my $stderr;
run3 [split(/\s+/, $MAKEPATH), '-f', 'no/no/no'], \undef, \undef, \$stderr;
#die $stderr;
if ($stderr =~ /^(\S+)\s*:/) {
$MAKE = $1;
$MAKE =~ s/(.*[\\\/])//;
} else {
$MAKE = '';
}
### $MAKE
#$MAKE =~ s{\\}{/}g;
}
sub set_shell ($$) {
my ($env_name, $default) = @_;
$SHELL = $ENV{$env_name} || $default;
}
BEGIN {
if ($^O =~ / /) {
$PERL = 'perl';
} else {
$PERL = $^X;
}
#warn $PERL;
# Get a clean environment
clean_env();
# Delay the Test::Base filters
filters_delay();
}
sub use_source_ditto () {
$UseSourceDitto = 1;
}
sub run_test ($) {
my $block = shift;
my $tempdir = tempdir( 'backend_XXXXXX', TMPDIR => 1, CLEANUP => 1 );
my $saved_cwd = Cwd::cwd;
chdir $tempdir;
$PWD = $tempdir;
$PWD =~ s,\\,/,g;
%::ExtraENV = ();
my $filename = $block->filename;
chomp $filename if $filename;
my $source = $block->source;
if (defined $source) {
my $fh;
if (not $filename) {
($fh, $filename) =
tempfile( "Makefile_XXXXX", DIR => '.', UNLINK => 1 );
} else {
open $fh, "> $filename" or
confess("can't open $filename for writing: $!");
}
$MAKEFILE = $filename;
$MAKEFILE =~ s,\\,/,g;
$block->run_filters;
$SavedSource = $block->source if $UseSourceDitto;
print $fh $block->source;
close $fh;
} else {
$block->run_filters;
$filename = $block->filename;
}
process_pre($block);
process_touch($block);
process_utouch($block);
{
no warnings 'uninitialized';
local %ENV = %ENV;
%ENV = (%ENV, %::ExtraENV) if %::ExtraENV;
run_make($block, $filename);
process_post($block);
process_found($block);
process_not_found($block);
%::ExtraENV = ();
}
chdir $saved_cwd;
#warn "\nstderr: $stderr\nstdout: $stdout\n";
}
sub run_tests () {
for my $block (blocks()) {
run_test($block);
}
}
sub create_file ($$) {
my ($filename, $content) = @_;
my $fh;
if (not $filename) {
($fh, $filename) =
tempfile( "create_file_XXXXX", DIR => '.', UNLINK => 1 );
} else {
open $fh, "> $filename" or
confess("can't open $filename for writing: $!");
}
#$content .= "\n\nSHELL=$SHELL" if $SHELL;
print $fh $content;
close $fh;
return $filename;
}
sub process_touch ($) {
my $block = shift;
my $buf = $block->touch;
return if not $buf;
touch(split /\s+/, $buf);
}
sub process_utouch ($) {
my $block = shift;
my $buf = $block->utouch;
return if not $buf;
my @pairs = split /\s+/, $buf;
### @pairs
while (@pairs) {
my $time = shift @pairs;
my $file = shift @pairs;
utouch($time => $file);
}
}
sub set_filters (@) {
%Filters = @_;
}
# returns ($errcode, $stdout, $stderr) or $errcode
sub run_make($$) {
my ($block, $filename) = @_;
my $options = $block->options || '';
my $goals = $block->goals || '';
@MakeExe = split_arg($MAKEPATH) if not @MakeExe;
#warn Dumper($filename);
my (@pre, @post);
if ($filename and $options !~ /-f\s+\S+/) {
push @pre, '-f', $filename;
}
if ($SHELL and $options !~ m/SHELL\s*=\s*/ and $^O eq 'MSWin32') {
push @post, "SHELL=$SHELL";
}
my $cmd = [
@MakeExe,
@pre,
process_args("$options $goals"),
@post,
];
#warn Dumper($cmd);
test_shell_command( $block, $cmd, %Filters );
}
package Test::Make::Base::Filter;
use Test::Base::Filter -Base;
sub quote {
qq/"$_[0]"/;
}
sub preprocess {
my $s = shift;
return if not defined $s;
### $Test::Make::Bae::MAKE
$s =~ s/\#MAKE\#/$Test::Make::Base::MAKE/gsi;
$s =~ s/\#MAKEPATH\#/$Test::Make::Base::MAKEPATH/gs;
$s =~ s/\#MAKEFILE\#/$Test::Make::Base::MAKEFILE/gs;
$s =~ s/\#PWD\#/$Test::Make::Base::PWD/gs;
return $s;
}
sub preprocess_like {
my $s = shift;
return if not defined $s;
$s =~ s/\#MAKE\#/quotemeta $Test::Make::Base::MAKE/gse;
$s =~ s/\#MAKEPATH\#/quotemeta $Test::Make::Base::MAKEPATH/gse;
$s =~ s/\#MAKEFILE\#/quotemeta $Test::Make::Base::MAKEFILE/gse;
$s =~ s/\#PWD\#/quotemeta $Test::Make::Base::PWD/gse;
return $s;
}
sub expand {
my $s = shift;
return if not $s;
return eval(qq{"$s"});
}
sub ditto {
if (!defined $UseSourceDitto) {
die "Error: ditto found while no use_source_ditto call.\n";
}
$SavedSource;
}
1;