1#! perl -w 2 3use strict; 4use Test::More tests => 64; 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# 156$base = ExtUtils::CBuilder::Base->new( quiet => 1 ); 157ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); 158isa_ok( $base, 'ExtUtils::CBuilder::Base' ); 159 160$source_file = File::Spec->catfile('t', 'baset.c'); 161create_c_source_file($source_file); 162ok(-e $source_file, "source file '$source_file' created"); 163 164my %args = (); 165my @defines = $base->arg_defines( %args ); 166ok( ! @defines, "Empty hash passed to arg_defines() returns empty list" ); 167 168%args = ( alpha => 'beta', gamma => 'delta' ); 169my $defines_seen_ref = { map { $_ => 1 } $base->arg_defines( %args ) }; 170is_deeply( 171 $defines_seen_ref, 172 { '-Dalpha=beta' => 1, '-Dgamma=delta' => 1 }, 173 "arg_defines(): got expected defines", 174); 175 176my $include_dirs_seen_ref = 177 { map {$_ => 1} $base->arg_include_dirs( qw| alpha beta gamma | ) }; 178is_deeply( 179 $include_dirs_seen_ref, 180 { '-Ialpha' => 1, '-Ibeta' => 1, '-Igamma' => 1 }, 181 "arg_include_dirs(): got expected include_dirs", 182); 183 184is( '-c', $base->arg_nolink(), "arg_nolink(): got expected value" ); 185 186my $seen_ref = 187 { map {$_ => 1} $base->arg_object_file('alpha') }; 188is_deeply( 189 $seen_ref, 190 { '-o' => 1, 'alpha' => 1 }, 191 "arg_object_file(): got expected option flag and value", 192); 193 194$seen_ref = { map {$_ => 1} $base->arg_share_object_file('alpha') }; 195my %exp = map {$_ => 1} $base->split_like_shell($base->{config}{lddlflags}); 196$exp{'-o'} = 1; 197$exp{'alpha'} = 1; 198 199is_deeply( 200 $seen_ref, 201 \%exp, 202 "arg_share_object_file(): got expected option flag and value", 203); 204 205$seen_ref = 206 { map {$_ => 1} $base->arg_exec_file('alpha') }; 207is_deeply( 208 $seen_ref, 209 { '-o' => 1, 'alpha' => 1 }, 210 "arg_exec_file(): got expected option flag and value", 211); 212 213ok(! $base->split_like_shell(undef), 214 "split_like_shell(): handled undefined argument as expected" ); 215 216my $array_ref = [ qw| alpha beta gamma | ]; 217my %split_seen = map { $_ => 1 } $base->split_like_shell($array_ref); 218%exp = ( alpha => 1, beta => 1, gamma => 1 ); 219is_deeply( \%split_seen, \%exp, 220 "split_like_shell(): handled array ref as expected" ); 221 222{ 223 $cwd = cwd(); 224 my $tdir = tempdir(CLEANUP => 1); 225 my $subdir = File::Spec->catdir( 226 $tdir, qw| alpha beta gamma delta epsilon 227 zeta eta theta iota kappa lambda | 228 ); 229 mkpath($subdir, { mode => 0711 } ); 230 chdir $subdir 231 or die "Unable to change to temporary directory for testing"; 232 local $ENV{PERL_CORE} = 1; 233 my $capture = q{}; 234 local $SIG{__WARN__} = sub { $capture = $_[0] }; 235 my $expected_message = 236 qr/PERL_CORE is set but I can't find your perl source!/; #' 237 my $rv; 238 239 $rv = $base->perl_src(); 240 is( $rv, q{}, "perl_src(): returned empty string as expected" ); 241 like( $capture, $expected_message, 242 "perl_src(): got expected warning" ); 243 $capture = q{}; 244 245 my $config = File::Spec->catfile( $subdir, 'config_h.SH' ); 246 touch_file($config); 247 $rv = $base->perl_src(); 248 is( $rv, q{}, "perl_src(): returned empty string as expected" ); 249 like( $capture, $expected_message, 250 "perl_src(): got expected warning" ); 251 $capture = q{}; 252 253 my $perlh = File::Spec->catfile( $subdir, 'perl.h' ); 254 touch_file($perlh); 255 $rv = $base->perl_src(); 256 is( $rv, q{}, "perl_src(): returned empty string as expected" ); 257 like( $capture, $expected_message, 258 "perl_src(): got expected warning" ); 259 $capture = q{}; 260 261 my $libsubdir = File::Spec->catdir( $subdir, 'lib' ); 262 mkpath($libsubdir, { mode => 0711 } ); 263 my $exporter = File::Spec->catfile( $libsubdir, 'Exporter.pm' ); 264 touch_file($exporter); 265 $rv = $base->perl_src(); 266 ok( -d $rv, "perl_src(): returned a directory" ); 267 my $rp = Cwd::realpath($subdir); 268 SKIP: { 269 if ($^O eq 'dec_osf' && $rp =~ m[^/cluster/members/]) { 270 skip "Tru64 cluster filesystem", 1; 271 } # SKIP 272 is( uc($rv), uc($rp), "perl_src(): identified directory" ); 273 } 274 is( $capture, q{}, "perl_src(): no warning, as expected" ); 275 276 chdir $cwd 277 or die "Unable to change from temporary directory after testing"; 278} 279 280my ($dl_file_out, $mksymlists_args); 281my $dlf = 'Kappa'; 282%args = ( 283 dl_vars => [ qw| alpha beta gamma | ], 284 dl_funcs => { 285 'Homer::Iliad' => [ qw(trojans greeks) ], 286 'Homer::Odyssey' => [ qw(travellers family suitors) ], 287 }, 288 dl_func_list => [ qw| delta epsilon | ], 289 dl_imports => { zeta => 'eta', theta => 'iota' }, 290 dl_name => 'Tk::Canvas', 291 dl_base => 'Tk::Canvas.ext', 292 dl_file => $dlf, 293 dl_version => '7.7', 294); 295($dl_file_out, $mksymlists_args) = 296 ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args); 297is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): Got expected name for dl_file" ); 298is_deeply( $mksymlists_args, 299 { 300 DL_VARS => [ qw| alpha beta gamma | ], 301 DL_FUNCS => { 302 'Homer::Iliad' => [ qw(trojans greeks) ], 303 'Homer::Odyssey' => [ qw(travellers family suitors) ], 304 }, 305 FUNCLIST => [ qw| delta epsilon | ], 306 IMPORTS => { zeta => 'eta', theta => 'iota' }, 307 NAME => 'Tk::Canvas', 308 DLBASE => 'Tk::Canvas.ext', 309 FILE => $dlf, 310 VERSION => '7.7', 311 }, 312 "_prepare_mksymlists_args(): got expected arguments for Mksymlists", 313); 314 315$dlf = 'Canvas'; 316%args = ( 317 dl_name => 'Tk::Canvas', 318 dl_base => 'Tk::Canvas.ext', 319); 320($dl_file_out, $mksymlists_args) = 321 ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args); 322is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): got expected name for dl_file" ); 323is_deeply( $mksymlists_args, 324 { 325 DL_VARS => [], 326 DL_FUNCS => {}, 327 FUNCLIST => [], 328 IMPORTS => {}, 329 NAME => 'Tk::Canvas', 330 DLBASE => 'Tk::Canvas.ext', 331 FILE => $dlf, 332 VERSION => '0.0', 333 }, 334 "_prepare_mksymlists_args(): got expected arguments for Mksymlists", 335); 336 337my %testvars = ( 338 CFLAGS => 'ccflags', 339 LDFLAGS => 'ldflags', 340); 341 342while (my ($VAR, $var) = each %testvars) { 343 local $ENV{$VAR}; 344 $base = ExtUtils::CBuilder::Base->new( quiet => 1 ); 345 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); 346 isa_ok( $base, 'ExtUtils::CBuilder::Base' ); 347 like($base->{config}{$var}, qr/\Q$Config{$var}/, 348 "honours $var from Config.pm"); 349 350 $ENV{$VAR} = "-foo -bar"; 351 $base = ExtUtils::CBuilder::Base->new( quiet => 1 ); 352 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); 353 isa_ok( $base, 'ExtUtils::CBuilder::Base' ); 354 like($base->{config}{$var}, qr/\Q$ENV{$VAR}/, 355 "honours $VAR from the environment"); 356 like($base->{config}{$var}, qr/\Q$Config{$var}/, 357 "doesn't override $var from Config.pm with $VAR from the environment"); 358} 359 360##### 361 362for ($source_file, $object_file, $lib_file) { 363 next unless defined $_; 364 tr/"'//d; #" 365 1 while unlink; 366} 367 368pass("Completed all tests in $0"); 369 370if ($^O eq 'VMS') { 371 1 while unlink 'BASET.LIS'; 372 1 while unlink 'BASET.OPT'; 373} 374 375sub create_c_source_file { 376 my $source_file = shift; 377 open my $FH, '>', $source_file or die "Can't create $source_file: $!"; 378 print $FH "int boot_baset(void) { return 1; }\n"; 379 close $FH; 380} 381 382sub touch_file { 383 my $f = shift; 384 open my $FH, '>', $f or die "Can't create $f: $!"; 385 print $FH "\n"; 386 close $FH; 387 return $f; 388} 389