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 is( uc($rv), uc(Cwd::realpath($subdir)), "perl_src(): identified directory" ); 268 is( $capture, q{}, "perl_src(): no warning, as expected" ); 269 270 chdir $cwd 271 or die "Unable to change from temporary directory after testing"; 272} 273 274my ($dl_file_out, $mksymlists_args); 275my $dlf = 'Kappa'; 276%args = ( 277 dl_vars => [ qw| alpha beta gamma | ], 278 dl_funcs => { 279 'Homer::Iliad' => [ qw(trojans greeks) ], 280 'Homer::Odyssey' => [ qw(travellers family suitors) ], 281 }, 282 dl_func_list => [ qw| delta epsilon | ], 283 dl_imports => { zeta => 'eta', theta => 'iota' }, 284 dl_name => 'Tk::Canvas', 285 dl_base => 'Tk::Canvas.ext', 286 dl_file => $dlf, 287 dl_version => '7.7', 288); 289($dl_file_out, $mksymlists_args) = 290 ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args); 291is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): Got expected name for dl_file" ); 292is_deeply( $mksymlists_args, 293 { 294 DL_VARS => [ qw| alpha beta gamma | ], 295 DL_FUNCS => { 296 'Homer::Iliad' => [ qw(trojans greeks) ], 297 'Homer::Odyssey' => [ qw(travellers family suitors) ], 298 }, 299 FUNCLIST => [ qw| delta epsilon | ], 300 IMPORTS => { zeta => 'eta', theta => 'iota' }, 301 NAME => 'Tk::Canvas', 302 DLBASE => 'Tk::Canvas.ext', 303 FILE => $dlf, 304 VERSION => '7.7', 305 }, 306 "_prepare_mksymlists_args(): got expected arguments for Mksymlists", 307); 308 309$dlf = 'Canvas'; 310%args = ( 311 dl_name => 'Tk::Canvas', 312 dl_base => 'Tk::Canvas.ext', 313); 314($dl_file_out, $mksymlists_args) = 315 ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args); 316is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): got expected name for dl_file" ); 317is_deeply( $mksymlists_args, 318 { 319 DL_VARS => [], 320 DL_FUNCS => {}, 321 FUNCLIST => [], 322 IMPORTS => {}, 323 NAME => 'Tk::Canvas', 324 DLBASE => 'Tk::Canvas.ext', 325 FILE => $dlf, 326 VERSION => '0.0', 327 }, 328 "_prepare_mksymlists_args(): got expected arguments for Mksymlists", 329); 330 331my %testvars = ( 332 CFLAGS => 'ccflags', 333 LDFLAGS => 'ldflags', 334); 335 336while (my ($VAR, $var) = each %testvars) { 337 local $ENV{$VAR}; 338 $base = ExtUtils::CBuilder::Base->new( quiet => 1 ); 339 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); 340 isa_ok( $base, 'ExtUtils::CBuilder::Base' ); 341 like($base->{config}{$var}, qr/\Q$Config{$var}/, 342 "honours $var from Config.pm"); 343 344 $ENV{$VAR} = "-foo -bar"; 345 $base = ExtUtils::CBuilder::Base->new( quiet => 1 ); 346 ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); 347 isa_ok( $base, 'ExtUtils::CBuilder::Base' ); 348 like($base->{config}{$var}, qr/\Q$ENV{$VAR}/, 349 "honours $VAR from the environment"); 350 like($base->{config}{$var}, qr/\Q$Config{$var}/, 351 "doesn't override $var from Config.pm with $VAR from the environment"); 352} 353 354##### 355 356for ($source_file, $object_file, $lib_file) { 357 next unless defined $_; 358 tr/"'//d; #" 359 1 while unlink; 360} 361 362pass("Completed all tests in $0"); 363 364if ($^O eq 'VMS') { 365 1 while unlink 'BASET.LIS'; 366 1 while unlink 'BASET.OPT'; 367} 368 369sub create_c_source_file { 370 my $source_file = shift; 371 open my $FH, '>', $source_file or die "Can't create $source_file: $!"; 372 print $FH "int boot_baset(void) { return 1; }\n"; 373 close $FH; 374} 375 376sub touch_file { 377 my $f = shift; 378 open my $FH, '>', $f or die "Can't create $f: $!"; 379 print $FH "\n"; 380 close $FH; 381 return $f; 382} 383