dist/ExtUtils-CBuilder/t/04-base.t

   1 #! perl -w
   2
   3 use strict;
   4 use Test::More tests => 65;
   5 use Config;
   6 use Cwd;
   7 use File::Path qw( mkpath );
   8 use File::Temp qw( tempdir );
   9 use ExtUtils::CBuilder::Base;
  10
  11 ## N.B.  There are pretty severe limits on what can portably be tested
  12 ## in the base class.  Specifically, don't do anything that will send
  13 ## actual compile and link commands to the shell as that won't work
  14 ## without the platform-specific overrides.
  15
  16 # XXX protect from user CC as we mock everything here
  17 local $ENV{CC};
  18
  19 my ( $base, $phony, $cwd );
  20 my ( $source_file, $object_file, $lib_file );
  21
  22 $base = ExtUtils::CBuilder::Base->new();
  23 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
  24 isa_ok( $base, 'ExtUtils::CBuilder::Base' );
  25
  26 {
  27   $phony = 'foobar';
  28   $base = ExtUtils::CBuilder::Base->new(
  29       config  => { cc => $phony },
  30   );
  31   ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
  32   isa_ok( $base, 'ExtUtils::CBuilder::Base' );
  33   is( $base->{config}->{cc}, $phony,
  34       "Got expected value when 'config' argument passed to new()" );
  35 }
  36
  37 {
  38     $phony = 'barbaz';
  39     local $ENV{CC} = $phony;
  40     $base = ExtUtils::CBuilder::Base->new();
  41     ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
  42     isa_ok( $base, 'ExtUtils::CBuilder::Base' );
  43     is( $base->{config}->{cc}, $phony,
  44         "Got expected value \$ENV{CC} set" );
  45 }
  46
  47 {
  48     my $path_to_perl = $^O eq 'VMS'
  49                        ? 'perl_root:[000000]perl.exe'
  50                        : File::Spec->catfile( '', qw| usr bin perl | );
  51     local $^X = $path_to_perl;
  52     is(
  53         ExtUtils::CBuilder::Base::find_perl_interpreter(),
  54         $path_to_perl,
  55         "find_perl_interpreter() returned expected absolute path"
  56     );
  57 }
  58
  59 SKIP:
  60 {
  61     skip "Base doesn't know about override on VMS", 1
  62         if $^O eq 'VMS';
  63
  64     my $path_to_perl = 'foobar';
  65     local $^X = $path_to_perl;
  66     # %Config is read-only.  We cannot assign to it and we therefore cannot
  67     # simulate the condition that would occur were its value something other
  68     # than an existing file.
  69     if ( !$ENV{PERL_CORE} and $Config::Config{perlpath}) {
  70         is(
  71             ExtUtils::CBuilder::Base::find_perl_interpreter(),
  72             $Config::Config{perlpath},
  73             "find_perl_interpreter() returned expected file"
  74         );
  75     }
  76     else {
  77         local $^X = $path_to_perl = File::Spec->rel2abs($path_to_perl);
  78         is(
  79             ExtUtils::CBuilder::Base::find_perl_interpreter(),
  80             $path_to_perl,
  81             "find_perl_interpreter() returned expected name"
  82         );
  83     }
  84 }
  85
  86 {
  87     $cwd = cwd();
  88     my $tdir = tempdir(CLEANUP => 1);
  89     chdir $tdir;
  90     $base = ExtUtils::CBuilder::Base->new();
  91     ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
  92     isa_ok( $base, 'ExtUtils::CBuilder::Base' );
  93     is( scalar keys %{$base->{files_to_clean}}, 0,
  94         "No files needing cleaning yet" );
  95
  96     my $file_for_cleaning = File::Spec->catfile( $tdir, 'foobar' );
  97     open my $IN, '>', $file_for_cleaning
  98         or die "Unable to open dummy file: $!";
  99     print $IN "\n";
 100     close $IN or die "Unable to close dummy file: $!";
 101
 102     $base->add_to_cleanup( $file_for_cleaning );
 103     is( scalar keys %{$base->{files_to_clean}}, 1,
 104         "One file needs cleaning" );
 105
 106     $base->cleanup();
 107     ok( ! -f $file_for_cleaning, "File was cleaned up" );
 108
 109     chdir $cwd;
 110 }
 111
 112 # fake compiler is perl and will always succeed
 113 $base = ExtUtils::CBuilder::Base->new(
 114     config  => {
 115         cc => File::Spec->rel2abs($^X) . " -e1 --",
 116         ld => File::Spec->rel2abs($^X) . " -e1 --",
 117     }
 118 );
 119 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
 120 isa_ok( $base, 'ExtUtils::CBuilder::Base' );
 121 eval {
 122     $base->compile(foo => 'bar');
 123 };
 124 like(
 125     $@,
 126     qr/Missing 'source' argument to compile/,
 127     "Got expected error message when lacking 'source' argument to compile()"
 128 );
 129
 130 $base = ExtUtils::CBuilder::Base->new( quiet => 1 );
 131 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
 132 isa_ok( $base, 'ExtUtils::CBuilder::Base' );
 133
 134 $source_file = File::Spec->catfile('t', 'baset.c');
 135 create_c_source_file($source_file);
 136 ok(-e $source_file, "source file '$source_file' created");
 137
 138 # object filename automatically assigned
 139 my $obj_ext = $base->{config}{obj_ext};
 140 is( $base->object_file($source_file),
 141     File::Spec->catfile('t', "baset$obj_ext"),
 142     "object_file(): got expected automatically assigned name for object file"
 143 );
 144
 145 my ($lib, @temps);
 146
 147
 148 {
 149     local $ENV{PERL_CORE} = '' unless $ENV{PERL_CORE};
 150     my $include_dir = $base->perl_inc();
 151     ok( $include_dir, "perl_inc() returned true value" );
 152     ok( -d $include_dir, "perl_inc() returned directory" );
 153 }
 154
 155 $base = ExtUtils::CBuilder::Base->new( quiet => 1 );
 156 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
 157 isa_ok( $base, 'ExtUtils::CBuilder::Base' );
 158
 159 $source_file = File::Spec->catfile('t', 'baset.c');
 160 create_c_source_file($source_file);
 161 ok(-e $source_file, "source file '$source_file' created");
 162
 163 my %args = ();
 164 my @defines = $base->arg_defines( %args );
 165 ok( ! @defines, "Empty hash passed to arg_defines() returns empty list" );
 166
 167 my @epsilon = ( epsilon => 'zeta' );
 168 my @eta     = ( eta => 'theta' );
 169 my @alpha   = ( alpha => 'beta' );
 170 my @gamma   = ( gamma => 'delta' );
 171 my @all = (\@epsilon, \@eta, \@alpha, \@gamma);
 172
 173 %args = map { @{$_} } @all;
 174 @defines = $base->arg_defines( %args );
 175 my $defines_seen_ref = { map { $_ => 1 } @defines };
 176 my $defines_expected_ref;
 177 for my $r (@all) {
 178     $defines_expected_ref->{"-D$r->[0]=$r->[1]"} = 1;
 179 }
 180 is_deeply(
 181     $defines_seen_ref,
 182     $defines_expected_ref,
 183     "arg_defines(): got expected defines",
 184 );
 185 my $ordered_defines_expected_ref = [ sort keys %{$defines_expected_ref} ];
 186 is_deeply(\@defines, $ordered_defines_expected_ref,
 187     "Got expected order of defines: RT #124106");
 188
 189 my $include_dirs_seen_ref =
 190     { map {$_ => 1} $base->arg_include_dirs( qw| alpha beta gamma | ) };
 191 is_deeply(
 192     $include_dirs_seen_ref,
 193     { '-Ialpha' => 1, '-Ibeta' => 1, '-Igamma' => 1 },
 194     "arg_include_dirs(): got expected include_dirs",
 195 );
 196
 197 is( '-c', $base->arg_nolink(), "arg_nolink(): got expected value" );
 198
 199 my $seen_ref =
 200     { map {$_ => 1} $base->arg_object_file('alpha') };
 201 is_deeply(
 202     $seen_ref,
 203     { '-o'  => 1, 'alpha' => 1 },
 204     "arg_object_file(): got expected option flag and value",
 205 );
 206
 207 $seen_ref = { map {$_ => 1} $base->arg_share_object_file('alpha') };
 208 my %exp = map {$_ => 1} $base->split_like_shell($base->{config}{lddlflags});
 209 $exp{'-o'} = 1;
 210 $exp{'alpha'} = 1;
 211
 212 is_deeply(
 213     $seen_ref,
 214     \%exp,
 215     "arg_share_object_file(): got expected option flag and value",
 216 );
 217
 218 $seen_ref =
 219     { map {$_ => 1} $base->arg_exec_file('alpha') };
 220 is_deeply(
 221     $seen_ref,
 222     { '-o'  => 1, 'alpha' => 1 },
 223     "arg_exec_file(): got expected option flag and value",
 224 );
 225
 226 ok(! $base->split_like_shell(undef),
 227     "split_like_shell(): handled undefined argument as expected" );
 228
 229 my $array_ref = [ qw| alpha beta gamma | ];
 230 my %split_seen = map { $_ => 1 } $base->split_like_shell($array_ref);
 231 %exp = ( alpha => 1, beta => 1, gamma => 1 );
 232 is_deeply( \%split_seen, \%exp,
 233     "split_like_shell(): handled array ref as expected" );
 234
 235 {
 236     $cwd = cwd();
 237     my $tdir = tempdir(CLEANUP => 1);
 238     my $subdir = File::Spec->catdir(
 239         $tdir, qw| alpha beta gamma delta epsilon
 240             zeta eta theta iota kappa lambda |
 241     );
 242     mkpath($subdir, { mode => 0711 } );
 243     chdir $subdir
 244         or die "Unable to change to temporary directory for testing";
 245     local $ENV{PERL_CORE} = 1;
 246     my $capture = q{};
 247     local $SIG{__WARN__} = sub { $capture = $_[0] };
 248     my $expected_message =
 249         qr/PERL_CORE is set but I can't find your perl source!/; #'
 250     my $rv;
 251
 252     $rv = $base->perl_src();
 253     is( $rv, q{}, "perl_src(): returned empty string as expected" );
 254     like( $capture, $expected_message,
 255         "perl_src(): got expected warning" );
 256     $capture = q{};
 257
 258     my $config = File::Spec->catfile( $subdir, 'config_h.SH' );
 259     touch_file($config);
 260     $rv = $base->perl_src();
 261     is( $rv, q{}, "perl_src(): returned empty string as expected" );
 262     like( $capture, $expected_message,
 263         "perl_src(): got expected warning" );
 264     $capture = q{};
 265
 266     my $perlh = File::Spec->catfile( $subdir, 'perl.h' );
 267     touch_file($perlh);
 268     $rv = $base->perl_src();
 269     is( $rv, q{}, "perl_src(): returned empty string as expected" );
 270     like( $capture, $expected_message,
 271         "perl_src(): got expected warning" );
 272     $capture = q{};
 273
 274     my $libsubdir = File::Spec->catdir( $subdir, 'lib' );
 275     mkpath($libsubdir, { mode => 0711 } );
 276     my $exporter = File::Spec->catfile( $libsubdir, 'Exporter.pm' );
 277     touch_file($exporter);
 278     $rv = $base->perl_src();
 279     ok( -d $rv, "perl_src(): returned a directory" );
 280     my $rp = Cwd::realpath($subdir);
 281   SKIP: {
 282       if ($^O eq 'dec_osf' && $rp =~ m[^/cluster/members/]) {
 283           skip "Tru64 cluster filesystem", 1;
 284       } # SKIP
 285       elsif ($^O eq 'os390') {
 286         # os390 also has cluster-like things called 'sysplexed'.  So far, the
 287         # tail end of the path matches what we passed it (with some prepended
 288         # directories).  So test for that.
 289         like( uc($rp), qr/\U\Q$rp\E$/, "perl_src(): identified directory" );
 290       }
 291       else {
 292         is( uc($rv), uc($rp), "perl_src(): identified directory" );
 293       }
 294     }
 295     is( $capture, q{}, "perl_src(): no warning, as expected" );
 296
 297     chdir $cwd
 298         or die "Unable to change from temporary directory after testing";
 299 }
 300
 301 my ($dl_file_out, $mksymlists_args);
 302 my $dlf = 'Kappa';
 303 %args = (
 304     dl_vars         => [ qw| alpha beta gamma | ],
 305     dl_funcs        => {
 306         'Homer::Iliad'      => [ qw(trojans greeks) ],
 307         'Homer::Odyssey'    => [ qw(travellers family suitors) ],
 308     },
 309     dl_func_list    => [ qw| delta epsilon | ],
 310     dl_imports      => { zeta => 'eta', theta => 'iota' },
 311     dl_name         => 'Tk::Canvas',
 312     dl_base         => 'Tk::Canvas.ext',
 313     dl_file         => $dlf,
 314     dl_version      => '7.7',
 315 );
 316 ($dl_file_out, $mksymlists_args) =
 317     ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args);
 318 is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): Got expected name for dl_file" );
 319 is_deeply( $mksymlists_args,
 320     {
 321         DL_VARS         => [ qw| alpha beta gamma | ],
 322         DL_FUNCS        => {
 323             'Homer::Iliad'      => [ qw(trojans greeks) ],
 324             'Homer::Odyssey'    => [ qw(travellers family suitors) ],
 325         },
 326         FUNCLIST        => [ qw| delta epsilon | ],
 327         IMPORTS         => { zeta => 'eta', theta => 'iota' },
 328         NAME            => 'Tk::Canvas',
 329         DLBASE          => 'Tk::Canvas.ext',
 330         FILE            => $dlf,
 331         VERSION         => '7.7',
 332     },
 333     "_prepare_mksymlists_args(): got expected arguments for Mksymlists",
 334 );
 335
 336 $dlf = 'Canvas';
 337 %args = (
 338     dl_name         => 'Tk::Canvas',
 339     dl_base         => 'Tk::Canvas.ext',
 340 );
 341 ($dl_file_out, $mksymlists_args) =
 342     ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args);
 343 is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): got expected name for dl_file" );
 344 is_deeply( $mksymlists_args,
 345     {
 346         DL_VARS         => [],
 347         DL_FUNCS        => {},
 348         FUNCLIST        => [],
 349         IMPORTS         => {},
 350         NAME            => 'Tk::Canvas',
 351         DLBASE          => 'Tk::Canvas.ext',
 352         FILE            => $dlf,
 353         VERSION         => '0.0',
 354     },
 355     "_prepare_mksymlists_args(): got expected arguments for Mksymlists",
 356 );
 357
 358 my %testvars = (
 359     CFLAGS  => 'ccflags',
 360     LDFLAGS => 'ldflags',
 361 );
 362
 363 while (my ($VAR, $var) = each %testvars) {
 364     local $ENV{$VAR};
 365     $base = ExtUtils::CBuilder::Base->new( quiet => 1 );
 366     ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
 367     isa_ok( $base, 'ExtUtils::CBuilder::Base' );
 368     like($base->{config}{$var}, qr/\Q$Config{$var}/,
 369         "honours $var from Config.pm");
 370
 371     $ENV{$VAR} = "-foo -bar";
 372     $base = ExtUtils::CBuilder::Base->new( quiet => 1 );
 373     ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" );
 374     isa_ok( $base, 'ExtUtils::CBuilder::Base' );
 375     like($base->{config}{$var}, qr/\Q$ENV{$VAR}/,
 376         "honours $VAR from the environment");
 377     like($base->{config}{$var}, qr/\Q$Config{$var}/,
 378         "doesn't override $var from Config.pm with $VAR from the environment");
 379 }
 380
 381 #####
 382
 383 for ($source_file, $object_file, $lib_file) {
 384   next unless defined $_;
 385   tr/"'//d; #"
 386   1 while unlink;
 387 }
 388
 389 pass("Completed all tests in $0");
 390
 391 if ($^O eq 'VMS') {
 392    1 while unlink 'BASET.LIS';
 393    1 while unlink 'BASET.OPT';
 394 }
 395
 396 sub create_c_source_file {
 397     my $source_file = shift;
 398     open my $FH, '>', $source_file or die "Can't create $source_file: $!";
 399     print $FH "int boot_baset(void) { return 1; }\n";
 400     close $FH;
 401 }
 402
 403 sub touch_file {
 404     my $f = shift;
 405     open my $FH, '>', $f or die "Can't create $f: $!";
 406     print $FH "\n";
 407     close $FH;
 408     return $f;
 409 }