1#! perl -w 2 3use strict; 4use Test::More tests => 65; 5use Config; 6use Cwd; 7use File::Path qw( mkpath ); 8use File::Temp qw( tempdir ); 9use 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 17local $ENV{CC}; 18 19my ( $base, $phony, $cwd ); 20my ( $source_file, $object_file, $lib_file ); 21 22$base = ExtUtils::CBuilder::Base->new(); 23ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); 24isa_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 59SKIP: 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); 119ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); 120isa_ok( $base, 'ExtUtils::CBuilder::Base' ); 121eval { 122 $base->compile(foo => 'bar'); 123}; 124like( 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 ); 131ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); 132isa_ok( $base, 'ExtUtils::CBuilder::Base' ); 133 134$source_file = File::Spec->catfile('t', 'baset.c'); 135create_c_source_file($source_file); 136ok(-e $source_file, "source file '$source_file' created"); 137 138# object filename automatically assigned 139my $obj_ext = $base->{config}{obj_ext}; 140is( $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 145my ($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 ); 156ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); 157isa_ok( $base, 'ExtUtils::CBuilder::Base' ); 158 159$source_file = File::Spec->catfile('t', 'baset.c'); 160create_c_source_file($source_file); 161ok(-e $source_file, "source file '$source_file' created"); 162 163my %args = (); 164my @defines = $base->arg_defines( %args ); 165ok( ! @defines, "Empty hash passed to arg_defines() returns empty list" ); 166 167my @epsilon = ( epsilon => 'zeta' ); 168my @eta = ( eta => 'theta' ); 169my @alpha = ( alpha => 'beta' ); 170my @gamma = ( gamma => 'delta' ); 171my @all = (\@epsilon, \@eta, \@alpha, \@gamma); 172 173%args = map { @{$_} } @all; 174@defines = $base->arg_defines( %args ); 175my $defines_seen_ref = { map { $_ => 1 } @defines }; 176my $defines_expected_ref; 177for my $r (@all) { 178 $defines_expected_ref->{"-D$r->[0]=$r->[1]"} = 1; 179} 180is_deeply( 181 $defines_seen_ref, 182 $defines_expected_ref, 183 "arg_defines(): got expected defines", 184); 185my $ordered_defines_expected_ref = [ sort keys %{$defines_expected_ref} ]; 186is_deeply(\@defines, $ordered_defines_expected_ref, 187 "Got expected order of defines: RT #124106"); 188 189my $include_dirs_seen_ref = 190 { map {$_ => 1} $base->arg_include_dirs( qw| alpha beta gamma | ) }; 191is_deeply( 192 $include_dirs_seen_ref, 193 { '-Ialpha' => 1, '-Ibeta' => 1, '-Igamma' => 1 }, 194 "arg_include_dirs(): got expected include_dirs", 195); 196 197is( '-c', $base->arg_nolink(), "arg_nolink(): got expected value" ); 198 199my $seen_ref = 200 { map {$_ => 1} $base->arg_object_file('alpha') }; 201is_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') }; 208my %exp = map {$_ => 1} $base->split_like_shell($base->{config}{lddlflags}); 209$exp{'-o'} = 1; 210$exp{'alpha'} = 1; 211 212is_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') }; 220is_deeply( 221 $seen_ref, 222 { '-o' => 1, 'alpha' => 1 }, 223 "arg_exec_file(): got expected option flag and value", 224); 225 226ok(! $base->split_like_shell(undef), 227 "split_like_shell(): handled undefined argument as expected" ); 228 229my $array_ref = [ qw| alpha beta gamma | ]; 230my %split_seen = map { $_ => 1 } $base->split_like_shell($array_ref); 231%exp = ( alpha => 1, beta => 1, gamma => 1 ); 232is_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 301my ($dl_file_out, $mksymlists_args); 302my $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); 318is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): Got expected name for dl_file" ); 319is_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); 343is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): got expected name for dl_file" ); 344is_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 358my %testvars = ( 359 CFLAGS => 'ccflags', 360 LDFLAGS => 'ldflags', 361); 362 363while (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 383for ($source_file, $object_file, $lib_file) { 384 next unless defined $_; 385 tr/"'//d; #" 386 1 while unlink; 387} 388 389pass("Completed all tests in $0"); 390 391if ($^O eq 'VMS') { 392 1 while unlink 'BASET.LIS'; 393 1 while unlink 'BASET.OPT'; 394} 395 396sub 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 403sub 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} 410