#! perl -w
use strict;
use Test::More tests => 64;
use Config;
use Cwd;
use File::Path qw( mkpath );
use File::Temp qw( tempdir );
use ExtUtils::CBuilder::Base;
## N.B. There are pretty severe limits on what can portably be tested
## in the base class. Specifically, don't do anything that will send
## actual compile and link commands to the shell as that won't work
## without the platform-specific overrides.
# XXX protect from user CC as we mock everything here
local $ENV{CC};
my ( $base, $phony, $cwd );
my ( $source_file, $object_file, $lib_file );
$base = ExtUtils::CBuilder::Base->new();
ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
isa_ok( $base, 'ExtUtils::CBuilder::Base' );
{
$phony = 'foobar';
$base = ExtUtils::CBuilder::Base->new(
config => { cc => $phony },
);
ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
isa_ok( $base, 'ExtUtils::CBuilder::Base' );
is( $base->{config}->{cc}, $phony,
"Got expected value when 'config' argument passed to new()" );
}
{
$phony = 'barbaz';
local $ENV{CC} = $phony;
$base = ExtUtils::CBuilder::Base->new();
ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
isa_ok( $base, 'ExtUtils::CBuilder::Base' );
is( $base->{config}->{cc}, $phony,
"Got expected value \$ENV{CC} set" );
}
{
my $path_to_perl = $^O eq 'VMS'
? 'perl_root:[000000]perl.exe'
: File::Spec->catfile( '', qw| usr bin perl | );
local $^X = $path_to_perl;
is(
ExtUtils::CBuilder::Base::find_perl_interpreter(),
$path_to_perl,
"find_perl_interpreter() returned expected absolute path"
);
}
SKIP:
{
skip "Base doesn't know about override on VMS", 1
if $^O eq 'VMS';
my $path_to_perl = 'foobar';
local $^X = $path_to_perl;
# %Config is read-only. We cannot assign to it and we therefore cannot
# simulate the condition that would occur were its value something other
# than an existing file.
if ( !$ENV{PERL_CORE} and $Config::Config{perlpath}) {
is(
ExtUtils::CBuilder::Base::find_perl_interpreter(),
$Config::Config{perlpath},
"find_perl_interpreter() returned expected file"
);
}
else {
local $^X = $path_to_perl = File::Spec->rel2abs($path_to_perl);
is(
ExtUtils::CBuilder::Base::find_perl_interpreter(),
$path_to_perl,
"find_perl_interpreter() returned expected name"
);
}
}
{
$cwd = cwd();
my $tdir = tempdir(CLEANUP => 1);
chdir $tdir;
$base = ExtUtils::CBuilder::Base->new();
ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
isa_ok( $base, 'ExtUtils::CBuilder::Base' );
is( scalar keys %{$base->{files_to_clean}}, 0,
"No files needing cleaning yet" );
my $file_for_cleaning = File::Spec->catfile( $tdir, 'foobar' );
open my $IN, '>', $file_for_cleaning
or die "Unable to open dummy file: $!";
print $IN "\n";
close $IN or die "Unable to close dummy file: $!";
$base->add_to_cleanup( $file_for_cleaning );
is( scalar keys %{$base->{files_to_clean}}, 1,
"One file needs cleaning" );
$base->cleanup();
ok( ! -f $file_for_cleaning, "File was cleaned up" );
chdir $cwd;
}
# fake compiler is perl and will always succeed
$base = ExtUtils::CBuilder::Base->new(
config => {
cc => File::Spec->rel2abs($^X) . " -e1 --",
ld => File::Spec->rel2abs($^X) . " -e1 --",
}
);
ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
isa_ok( $base, 'ExtUtils::CBuilder::Base' );
eval {
$base->compile(foo => 'bar');
};
like(
$@,
qr/Missing 'source' argument to compile/,
"Got expected error message when lacking 'source' argument to compile()"
);
$base = ExtUtils::CBuilder::Base->new( quiet => 1 );
ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
isa_ok( $base, 'ExtUtils::CBuilder::Base' );
$source_file = File::Spec->catfile('t', 'baset.c');
create_c_source_file($source_file);
ok(-e $source_file, "source file '$source_file' created");
# object filename automatically assigned
my $obj_ext = $base->{config}{obj_ext};
is( $base->object_file($source_file),
File::Spec->catfile('t', "baset$obj_ext"),
"object_file(): got expected automatically assigned name for object file"
);
my ($lib, @temps);
{
local $ENV{PERL_CORE} = '' unless $ENV{PERL_CORE};
my $include_dir = $base->perl_inc();
ok( $include_dir, "perl_inc() returned true value" );
ok( -d $include_dir, "perl_inc() returned directory" );
}
#
$base = ExtUtils::CBuilder::Base->new( quiet => 1 );
ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
isa_ok( $base, 'ExtUtils::CBuilder::Base' );
$source_file = File::Spec->catfile('t', 'baset.c');
create_c_source_file($source_file);
ok(-e $source_file, "source file '$source_file' created");
my %args = ();
my @defines = $base->arg_defines( %args );
ok( ! @defines, "Empty hash passed to arg_defines() returns empty list" );
%args = ( alpha => 'beta', gamma => 'delta' );
my $defines_seen_ref = { map { $_ => 1 } $base->arg_defines( %args ) };
is_deeply(
$defines_seen_ref,
{ '-Dalpha=beta' => 1, '-Dgamma=delta' => 1 },
"arg_defines(): got expected defines",
);
my $include_dirs_seen_ref =
{ map {$_ => 1} $base->arg_include_dirs( qw| alpha beta gamma | ) };
is_deeply(
$include_dirs_seen_ref,
{ '-Ialpha' => 1, '-Ibeta' => 1, '-Igamma' => 1 },
"arg_include_dirs(): got expected include_dirs",
);
is( '-c', $base->arg_nolink(), "arg_nolink(): got expected value" );
my $seen_ref =
{ map {$_ => 1} $base->arg_object_file('alpha') };
is_deeply(
$seen_ref,
{ '-o' => 1, 'alpha' => 1 },
"arg_object_file(): got expected option flag and value",
);
$seen_ref = { map {$_ => 1} $base->arg_share_object_file('alpha') };
my %exp = map {$_ => 1} $base->split_like_shell($base->{config}{lddlflags});
$exp{'-o'} = 1;
$exp{'alpha'} = 1;
is_deeply(
$seen_ref,
\%exp,
"arg_share_object_file(): got expected option flag and value",
);
$seen_ref =
{ map {$_ => 1} $base->arg_exec_file('alpha') };
is_deeply(
$seen_ref,
{ '-o' => 1, 'alpha' => 1 },
"arg_exec_file(): got expected option flag and value",
);
ok(! $base->split_like_shell(undef),
"split_like_shell(): handled undefined argument as expected" );
my $array_ref = [ qw| alpha beta gamma | ];
my %split_seen = map { $_ => 1 } $base->split_like_shell($array_ref);
%exp = ( alpha => 1, beta => 1, gamma => 1 );
is_deeply( \%split_seen, \%exp,
"split_like_shell(): handled array ref as expected" );
{
$cwd = cwd();
my $tdir = tempdir(CLEANUP => 1);
my $subdir = File::Spec->catdir(
$tdir, qw| alpha beta gamma delta epsilon
zeta eta theta iota kappa lambda |
);
mkpath($subdir, { mode => 0711 } );
chdir $subdir
or die "Unable to change to temporary directory for testing";
local $ENV{PERL_CORE} = 1;
my $capture = q{};
local $SIG{__WARN__} = sub { $capture = $_[0] };
my $expected_message =
qr/PERL_CORE is set but I can't find your perl source!/; #'
my $rv;
$rv = $base->perl_src();
is( $rv, q{}, "perl_src(): returned empty string as expected" );
like( $capture, $expected_message,
"perl_src(): got expected warning" );
$capture = q{};
my $config = File::Spec->catfile( $subdir, 'config_h.SH' );
touch_file($config);
$rv = $base->perl_src();
is( $rv, q{}, "perl_src(): returned empty string as expected" );
like( $capture, $expected_message,
"perl_src(): got expected warning" );
$capture = q{};
my $perlh = File::Spec->catfile( $subdir, 'perl.h' );
touch_file($perlh);
$rv = $base->perl_src();
is( $rv, q{}, "perl_src(): returned empty string as expected" );
like( $capture, $expected_message,
"perl_src(): got expected warning" );
$capture = q{};
my $libsubdir = File::Spec->catdir( $subdir, 'lib' );
mkpath($libsubdir, { mode => 0711 } );
my $exporter = File::Spec->catfile( $libsubdir, 'Exporter.pm' );
touch_file($exporter);
$rv = $base->perl_src();
ok( -d $rv, "perl_src(): returned a directory" );
is( uc($rv), uc(Cwd::realpath($subdir)), "perl_src(): identified directory" );
is( $capture, q{}, "perl_src(): no warning, as expected" );
chdir $cwd
or die "Unable to change from temporary directory after testing";
}
my ($dl_file_out, $mksymlists_args);
my $dlf = 'Kappa';
%args = (
dl_vars => [ qw| alpha beta gamma | ],
dl_funcs => {
'Homer::Iliad' => [ qw(trojans greeks) ],
'Homer::Odyssey' => [ qw(travellers family suitors) ],
},
dl_func_list => [ qw| delta epsilon | ],
dl_imports => { zeta => 'eta', theta => 'iota' },
dl_name => 'Tk::Canvas',
dl_base => 'Tk::Canvas.ext',
dl_file => $dlf,
dl_version => '7.7',
);
($dl_file_out, $mksymlists_args) =
ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args);
is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): Got expected name for dl_file" );
is_deeply( $mksymlists_args,
{
DL_VARS => [ qw| alpha beta gamma | ],
DL_FUNCS => {
'Homer::Iliad' => [ qw(trojans greeks) ],
'Homer::Odyssey' => [ qw(travellers family suitors) ],
},
FUNCLIST => [ qw| delta epsilon | ],
IMPORTS => { zeta => 'eta', theta => 'iota' },
NAME => 'Tk::Canvas',
DLBASE => 'Tk::Canvas.ext',
FILE => $dlf,
VERSION => '7.7',
},
"_prepare_mksymlists_args(): got expected arguments for Mksymlists",
);
$dlf = 'Canvas';
%args = (
dl_name => 'Tk::Canvas',
dl_base => 'Tk::Canvas.ext',
);
($dl_file_out, $mksymlists_args) =
ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args);
is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): got expected name for dl_file" );
is_deeply( $mksymlists_args,
{
DL_VARS => [],
DL_FUNCS => {},
FUNCLIST => [],
IMPORTS => {},
NAME => 'Tk::Canvas',
DLBASE => 'Tk::Canvas.ext',
FILE => $dlf,
VERSION => '0.0',
},
"_prepare_mksymlists_args(): got expected arguments for Mksymlists",
);
my %testvars = (
CFLAGS => 'ccflags',
LDFLAGS => 'ldflags',
);
while (my ($VAR, $var) = each %testvars) {
local $ENV{$VAR};
$base = ExtUtils::CBuilder::Base->new( quiet => 1 );
ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
isa_ok( $base, 'ExtUtils::CBuilder::Base' );
like($base->{config}{$var}, qr/\Q$Config{$var}/,
"honours $var from Config.pm");
$ENV{$VAR} = "-foo -bar";
$base = ExtUtils::CBuilder::Base->new( quiet => 1 );
ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
isa_ok( $base, 'ExtUtils::CBuilder::Base' );
like($base->{config}{$var}, qr/\Q$ENV{$VAR}/,
"honours $VAR from the environment");
like($base->{config}{$var}, qr/\Q$Config{$var}/,
"doesn't override $var from Config.pm with $VAR from the environment");
}
#####
for ($source_file, $object_file, $lib_file) {
next unless defined $_;
tr/"'//d; #"
1 while unlink;
}
pass("Completed all tests in $0");
if ($^O eq 'VMS') {
1 while unlink 'BASET.LIS';
1 while unlink 'BASET.OPT';
}
sub create_c_source_file {
my $source_file = shift;
open my $FH, '>', $source_file or die "Can't create $source_file: $!";
print $FH "int boot_baset(void) { return 1; }\n";
close $FH;
}
sub touch_file {
my $f = shift;
open my $FH, '>', $f or die "Can't create $f: $!";
print $FH "\n";
close $FH;
return $f;
}