t/lib/extutils.t

   1 #!./perl -w
   2
   3 print "1..21\n";
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     @INC = '../lib';
   8 }
   9
  10 use warnings;
  11 use strict;
  12 use ExtUtils::MakeMaker;
  13 use ExtUtils::Constant qw (constant_types C_constant XS_constant autoload);
  14 use Config;
  15 use File::Spec::Functions;
  16 use File::Spec;
  17 # Because were are going to be changing directory before running Makefile.PL
  18 my $perl = File::Spec->rel2abs( $^X );
  19 # ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to
  20 # compare output to ensure that it is the same. We were probably run as ./perl
  21 # whereas we will run the child with the full path in $perl. So make $^X for
  22 # us the same as our child will see.
  23 $^X = $perl;
  24
  25 print "# perl=$perl\n";
  26 my $runperl = "$perl -x \"-I../../lib\"";
  27
  28 $| = 1;
  29
  30 my $dir = "ext-$$";
  31 my @files;
  32
  33 print "# $dir being created...\n";
  34 mkdir $dir, 0777 or die "mkdir: $!\n";
  35
  36
  37 END {
  38     use File::Path;
  39     print "# $dir being removed...\n";
  40     rmtree($dir);
  41 }
  42
  43 my $package = "ExtTest";
  44
  45 my @names = ("FIVE", {name=>"OK6", type=>"PV",},
  46              {name=>"OK7", type=>"PVN",
  47               value=>['"not ok 7\\n\\0ok 7\\n"', 15]},
  48              {name => "FARTHING", type=>"NV"},
  49              {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"},
  50              {name => "OPEN", type=>"PV", value=>'"/*"',
  51               macro=>["#if 1\n", "#endif\n"]},
  52              {name => "CLOSE", type=>"PV", value=>'"*/"',
  53               macro=>["#if 1\n", "#endif\n"]},
  54              {name => "ANSWER", default=>["UV", 42]}, "NOTDEF",
  55              {name => "Yes", type=>"YES"},
  56              {name => "No", type=>"NO"},
  57              {name => "Undef", type=>"UNDEF"}
  58 );
  59
  60 my @names_only = map {(ref $_) ? $_->{name} : $_} @names;
  61
  62 my $types = {};
  63 my $constant_types = constant_types(); # macro defs
  64 my $C_constant = join "\n",
  65   C_constant ($package, undef, "IV", $types, undef, undef, @names);
  66 my $XS_constant = XS_constant ($package, $types); # XS for ExtTest::constant
  67
  68 ################ Header
  69 my $header = catfile($dir, "test.h");
  70 push @files, "test.h";
  71 open FH, ">$header" or die "open >$header: $!\n";
  72 print FH <<'EOT';
  73 #define FIVE 5
  74 #define OK6 "ok 6\n"
  75 #define OK7 1
  76 #define FARTHING 0.25
  77 #define NOT_ZERO 1
  78 #define Yes 0
  79 #define No 1
  80 #define Undef 1
  81 #undef NOTDEF
  82 EOT
  83 close FH or die "close $header: $!\n";
  84
  85 ################ XS
  86 my $xs = catfile($dir, "$package.xs");
  87 push @files, "$package.xs";
  88 open FH, ">$xs" or die "open >$xs: $!\n";
  89
  90 print FH <<'EOT';
  91 #include "EXTERN.h"
  92 #include "perl.h"
  93 #include "XSUB.h"
  94 EOT
  95
  96 print FH "#include \"test.h\"\n\n";
  97 print FH $constant_types;
  98 print FH $C_constant, "\n";
  99 print FH "MODULE = $package             PACKAGE = $package\n";
 100 print FH "PROTOTYPES: ENABLE\n";
 101 print FH $XS_constant;
 102 close FH or die "close $xs: $!\n";
 103
 104 ################ PM
 105 my $pm = catfile($dir, "$package.pm");
 106 push @files, "$package.pm";
 107 open FH, ">$pm" or die "open >$pm: $!\n";
 108 print FH "package $package;\n";
 109 print FH "use $];\n";
 110
 111 print FH <<'EOT';
 112
 113 use strict;
 114 use warnings;
 115 use Carp;
 116
 117 require Exporter;
 118 require DynaLoader;
 119 use vars qw ($VERSION @ISA @EXPORT_OK);
 120
 121 $VERSION = '0.01';
 122 @ISA = qw(Exporter DynaLoader);
 123 @EXPORT_OK = qw(
 124 EOT
 125
 126 print FH "\t$_\n" foreach (@names_only);
 127 print FH ");\n";
 128 print FH autoload ($package, $]);
 129 print FH "bootstrap $package \$VERSION;\n1;\n__END__\n";
 130 close FH or die "close $pm: $!\n";
 131
 132 ################ test.pl
 133 my $testpl = catfile($dir, "test.pl");
 134 push @files, "test.pl";
 135 open FH, ">$testpl" or die "open >$testpl: $!\n";
 136
 137 print FH "use strict;\n";
 138 print FH "use $package qw(@names_only);\n";
 139 print FH <<'EOT';
 140
 141 # IV
 142 my $five = FIVE;
 143 if ($five == 5) {
 144   print "ok 5\n";
 145 } else {
 146   print "not ok 5 # $five\n";
 147 }
 148
 149 # PV
 150 print OK6;
 151
 152 # PVN containing embedded \0s
 153 $_ = OK7;
 154 s/.*\0//s;
 155 print;
 156
 157 # NV
 158 my $farthing = FARTHING;
 159 if ($farthing == 0.25) {
 160   print "ok 8\n";
 161 } else {
 162   print "not ok 8 # $farthing\n";
 163 }
 164
 165 # UV
 166 my $not_zero = NOT_ZERO;
 167 if ($not_zero > 0 && $not_zero == ~0) {
 168   print "ok 9\n";
 169 } else {
 170   print "not ok 9 # \$not_zero=$not_zero ~0=" . (~0) . "\n";
 171 }
 172
 173 # Value includes a "*/" in an attempt to bust out of a C comment.
 174 # Also tests custom cpp #if clauses
 175 my $close = CLOSE;
 176 if ($close eq '*/') {
 177   print "ok 10\n";
 178 } else {
 179   print "not ok 10 # \$close='$close'\n";
 180 }
 181
 182 # Default values if macro not defined.
 183 my $answer = ANSWER;
 184 if ($answer == 42) {
 185   print "ok 11\n";
 186 } else {
 187   print "not ok 11 # What do you get if you multiply six by nine? '$answer'\n";
 188 }
 189
 190 # not defined macro
 191 my $notdef = eval { NOTDEF; };
 192 if (defined $notdef) {
 193   print "not ok 12 # \$notdef='$notdef'\n";
 194 } elsif ($@ !~ /Your vendor has not defined ExtTest macro NOTDEF/) {
 195   print "not ok 12 # \$@='$@'\n";
 196 } else {
 197   print "ok 12\n";
 198 }
 199
 200 # not a macro
 201 my $notthere = eval { &ExtTest::NOTTHERE; };
 202 if (defined $notthere) {
 203   print "not ok 13 # \$notthere='$notthere'\n";
 204 } elsif ($@ !~ /NOTTHERE is not a valid ExtTest macro/) {
 205   chomp $@;
 206   print "not ok 13 # \$@='$@'\n";
 207 } else {
 208   print "ok 13\n";
 209 }
 210
 211 # Truth
 212 my $yes = Yes;
 213 if ($yes) {
 214   print "ok 14\n";
 215 } else {
 216   print "not ok 14 # $yes='\$yes'\n";
 217 }
 218
 219 # Falsehood
 220 my $no = No;
 221 if (defined $no and !$no) {
 222   print "ok 15\n";
 223 } else {
 224   print "not ok 15 # \$no=" . defined ($no) ? "'$no'\n" : "undef\n";
 225 }
 226
 227 # Undef
 228 my $undef = Undef;
 229 unless (defined $undef) {
 230   print "ok 16\n";
 231 } else {
 232   print "not ok 16 # \$undef='$undef'\n";
 233 }
 234
 235 EOT
 236
 237 close FH or die "close $testpl: $!\n";
 238
 239 ################ Makefile.PL
 240 # We really need a Makefile.PL because make test for a no dynamic linking perl
 241 # will run Makefile.PL again as part of the "make perl" target.
 242 my $makefilePL = catfile($dir, "Makefile.PL");
 243 push @files, "Makefile.PL";
 244 open FH, ">$makefilePL" or die "open >$makefilePL: $!\n";
 245 print FH <<"EOT";
 246 #!$perl -w
 247 use ExtUtils::MakeMaker;
 248 WriteMakefile(
 249               'NAME'            => "$package",
 250               'VERSION_FROM'    => "$package.pm", # finds \$VERSION
 251               (\$] >= 5.005 ?
 252                (#ABSTRACT_FROM => "$package.pm", # XXX add this
 253                 AUTHOR     => "$0") : ())
 254              );
 255 EOT
 256
 257 close FH or die "close $makefilePL: $!\n";
 258
 259 chdir $dir or die $!; push @INC,  '../../lib';
 260 END {chdir ".." or warn $!};
 261
 262 my @perlout = `$runperl Makefile.PL`;
 263 if ($?) {
 264   print "not ok 1 # $runperl Makefile.PL failed: $?\n";
 265   print "# $_" foreach @perlout;
 266   exit($?);
 267 } else {
 268   print "ok 1\n";
 269 }
 270
 271
 272 my $makefile = ($^O eq 'VMS' ? 'descrip' : 'Makefile');
 273 my $makefile_ext = ($^O eq 'VMS' ? '.mms' : '');
 274 if (-f "$makefile$makefile_ext") {
 275   print "ok 2\n";
 276 } else {
 277   print "not ok 2\n";
 278 }
 279 my $makefile_rename = ($^O eq 'VMS' ? '.mms' : '.old');
 280 push @files, "$makefile$makefile_rename"; # Renamed by make clean
 281
 282 my $make = $Config{make};
 283
 284 $make = $ENV{MAKE} if exists $ENV{MAKE};
 285
 286 my $makeout;
 287
 288 print "# make = '$make'\n";
 289 $makeout = `$make`;
 290 if ($?) {
 291   print "not ok 3 # $make failed: $?\n";
 292   exit($?);
 293 } else {
 294   print "ok 3\n";
 295 }
 296
 297 if ($Config{usedl}) {
 298   print "ok 4\n";
 299 } else {
 300   push @files, "perl$Config{exe_ext}";
 301   my $makeperl = "$make perl";
 302   print "# make = '$makeperl'\n";
 303   $makeout = `$makeperl`;
 304   if ($?) {
 305     print "not ok 4 # $makeperl failed: $?\n";
 306     exit($?);
 307   } else {
 308     print "ok 4\n";
 309   }
 310 }
 311
 312 my $test = 17;
 313 my $maketest = "$make test";
 314 print "# make = '$maketest'\n";
 315 $makeout = `$maketest`;
 316
 317 # echo of running the test script
 318 $makeout =~ s/^\s*PERL_DL_NONLAZY=.+?\n//m;
 319 $makeout =~ s/^MCR.+test.pl\n//mig if $^O eq 'VMS';
 320
 321 # GNU make babblings
 322 $makeout =~ s/^\w*?make.+?(?:entering|leaving) directory.+?\n//mig;
 323
 324 # Hopefully gets most make's babblings
 325 # make -f Makefile.aperl perl
 326 $makeout =~ s/^\w*?make.+\sperl[^A-Za-z0-9]*\n//mig;
 327 # make[1]: `perl' is up to date.
 328 $makeout =~ s/^\w*?make.+perl.+?is up to date.*?\n//mig;
 329
 330 print $makeout;
 331
 332 if ($?) {
 333   print "not ok $test # $maketest failed: $?\n";
 334 } else {
 335   print "ok $test\n";
 336 }
 337 $test++;
 338
 339 my $regen = `$runperl $package.xs`;
 340 if ($?) {
 341   print "not ok $test # $runperl $package.xs failed: $?\n";
 342 } else {
 343   print "ok $test\n";
 344 }
 345 $test++;
 346
 347 my $expect = $constant_types . $C_constant .
 348   "\n#### XS Section:\n" . $XS_constant;
 349
 350 if ($expect eq $regen) {
 351   print "ok $test\n";
 352 } else {
 353   print "not ok $test\n";
 354   # open FOO, ">expect"; print FOO $expect;
 355   # open FOO, ">regen"; print FOO $regen; close FOO;
 356 }
 357 $test++;
 358
 359 my $makeclean = "$make clean";
 360 print "# make = '$makeclean'\n";
 361 $makeout = `$makeclean`;
 362 if ($?) {
 363   print "not ok $test # $make failed: $?\n";
 364 } else {
 365   print "ok $test\n";
 366 }
 367 $test++;
 368
 369 foreach (@files) {
 370   unlink $_ or warn "unlink $_: $!";
 371 }
 372
 373 my $fail;
 374 opendir DIR, "." or die "opendir '.': $!";
 375 while (defined (my $entry = readdir DIR)) {
 376   next if $entry =~ /^\.\.?$/;
 377   print "# Extra file '$entry'\n";
 378   $fail = 1;
 379 }
 380 closedir DIR or warn "closedir '.': $!";
 381 if ($fail) {
 382   print "not ok $test\n";
 383 } else {
 384   print "ok $test\n";
 385 }