| 1 | #!/usr/bin/perl -w
|
|---|
| 2 |
|
|---|
| 3 | BEGIN {
|
|---|
| 4 | if( $ENV{PERL_CORE} ) {
|
|---|
| 5 | chdir 't' if -d 't';
|
|---|
| 6 | @INC = '../lib';
|
|---|
| 7 | }
|
|---|
| 8 | use Config;
|
|---|
| 9 | unless ($Config{usedl}) {
|
|---|
| 10 | print "1..0 # no usedl, skipping\n";
|
|---|
| 11 | exit 0;
|
|---|
| 12 | }
|
|---|
| 13 | }
|
|---|
| 14 |
|
|---|
| 15 | # use warnings;
|
|---|
| 16 | use strict;
|
|---|
| 17 | use ExtUtils::MakeMaker;
|
|---|
| 18 | use ExtUtils::Constant qw (constant_types C_constant XS_constant autoload);
|
|---|
| 19 | use File::Spec;
|
|---|
| 20 | use Cwd;
|
|---|
| 21 |
|
|---|
| 22 | my $do_utf_tests = $] > 5.006;
|
|---|
| 23 | my $better_than_56 = $] > 5.007;
|
|---|
| 24 | # For debugging set this to 1.
|
|---|
| 25 | my $keep_files = 0;
|
|---|
| 26 | $| = 1;
|
|---|
| 27 |
|
|---|
| 28 | # Because were are going to be changing directory before running Makefile.PL
|
|---|
| 29 | my $perl = $^X;
|
|---|
| 30 | # 5.005 doesn't have new enough File::Spec to have rel2abs. But actually we
|
|---|
| 31 | # only need it when $^X isn't absolute, which is going to be 5.8.0 or later
|
|---|
| 32 | # (where ExtUtils::Constant is in the core, and tests against the uninstalled
|
|---|
| 33 | # perl)
|
|---|
| 34 | $perl = File::Spec->rel2abs ($perl) unless $] < 5.006;
|
|---|
| 35 | # ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to
|
|---|
| 36 | # compare output to ensure that it is the same. We were probably run as ./perl
|
|---|
| 37 | # whereas we will run the child with the full path in $perl. So make $^X for
|
|---|
| 38 | # us the same as our child will see.
|
|---|
| 39 | $^X = $perl;
|
|---|
| 40 | my $lib = $ENV{PERL_CORE} ? '../../../lib' : '../../blib/lib';
|
|---|
| 41 | my $runperl = "$perl \"-I$lib\"";
|
|---|
| 42 | print "# perl=$perl\n";
|
|---|
| 43 |
|
|---|
| 44 | my $make = $Config{make};
|
|---|
| 45 | $make = $ENV{MAKE} if exists $ENV{MAKE};
|
|---|
| 46 | if ($^O eq 'MSWin32' && $make eq 'nmake') { $make .= " -nologo"; }
|
|---|
| 47 |
|
|---|
| 48 | # VMS may be using something other than MMS/MMK
|
|---|
| 49 | my $mms_or_mmk = 0;
|
|---|
| 50 | if ($^O eq 'VMS') {
|
|---|
| 51 | $mms_or_mmk = 1 if (($make eq 'MMK') || ($make eq 'MMS'));
|
|---|
| 52 | }
|
|---|
| 53 |
|
|---|
| 54 | # Renamed by make clean
|
|---|
| 55 | my $makefile = ($mms_or_mmk ? 'descrip' : 'Makefile');
|
|---|
| 56 | my $makefile_ext = ($mms_or_mmk ? '.mms' : '');
|
|---|
| 57 | my $makefile_rename = $makefile . ($mms_or_mmk ? '.mms_old' : '.old');
|
|---|
| 58 |
|
|---|
| 59 | my $output = "output";
|
|---|
| 60 | my $package = "ExtTest";
|
|---|
| 61 | my $dir = "ext-$$";
|
|---|
| 62 | my $subdir = 0;
|
|---|
| 63 | # The real test counter.
|
|---|
| 64 | my $realtest = 1;
|
|---|
| 65 |
|
|---|
| 66 | my $orig_cwd = cwd;
|
|---|
| 67 | my $updir = File::Spec->updir;
|
|---|
| 68 | die "Can't get current directory: $!" unless defined $orig_cwd;
|
|---|
| 69 |
|
|---|
| 70 | print "# $dir being created...\n";
|
|---|
| 71 | mkdir $dir, 0777 or die "mkdir: $!\n";
|
|---|
| 72 |
|
|---|
| 73 | END {
|
|---|
| 74 | if (defined $orig_cwd and length $orig_cwd) {
|
|---|
| 75 | chdir $orig_cwd or die "Can't chdir back to '$orig_cwd': $!";
|
|---|
| 76 | use File::Path;
|
|---|
| 77 | print "# $dir being removed...\n";
|
|---|
| 78 | rmtree($dir) unless $keep_files;
|
|---|
| 79 | } else {
|
|---|
| 80 | # Can't get here.
|
|---|
| 81 | die "cwd at start was empty, but directory '$dir' was created" if $dir;
|
|---|
| 82 | }
|
|---|
| 83 | }
|
|---|
| 84 |
|
|---|
| 85 | chdir $dir or die $!;
|
|---|
| 86 | push @INC, '../../lib', '../../../lib';
|
|---|
| 87 |
|
|---|
| 88 | sub check_for_bonus_files {
|
|---|
| 89 | my $dir = shift;
|
|---|
| 90 | my %expect = map {($^O eq 'VMS' ? lc($_) : $_), 1} @_;
|
|---|
| 91 |
|
|---|
| 92 | my $fail;
|
|---|
| 93 | opendir DIR, $dir or die "opendir '$dir': $!";
|
|---|
| 94 | while (defined (my $entry = readdir DIR)) {
|
|---|
| 95 | $entry =~ s/\.$// if $^O eq 'VMS'; # delete trailing dot that indicates no extension
|
|---|
| 96 | next if $expect{$entry};
|
|---|
| 97 | print "# Extra file '$entry'\n";
|
|---|
| 98 | $fail = 1;
|
|---|
| 99 | }
|
|---|
| 100 |
|
|---|
| 101 | closedir DIR or warn "closedir '.': $!";
|
|---|
| 102 | if ($fail) {
|
|---|
| 103 | print "not ok $realtest\n";
|
|---|
| 104 | } else {
|
|---|
| 105 | print "ok $realtest\n";
|
|---|
| 106 | }
|
|---|
| 107 | $realtest++;
|
|---|
| 108 | }
|
|---|
| 109 |
|
|---|
| 110 | sub build_and_run {
|
|---|
| 111 | my ($tests, $expect, $files) = @_;
|
|---|
| 112 | my $core = $ENV{PERL_CORE} ? ' PERL_CORE=1' : '';
|
|---|
| 113 | my @perlout = `$runperl Makefile.PL $core`;
|
|---|
| 114 | if ($?) {
|
|---|
| 115 | print "not ok $realtest # $runperl Makefile.PL failed: $?\n";
|
|---|
| 116 | print "# $_" foreach @perlout;
|
|---|
| 117 | exit($?);
|
|---|
| 118 | } else {
|
|---|
| 119 | print "ok $realtest\n";
|
|---|
| 120 | }
|
|---|
| 121 | $realtest++;
|
|---|
| 122 |
|
|---|
| 123 | if (-f "$makefile$makefile_ext") {
|
|---|
| 124 | print "ok $realtest\n";
|
|---|
| 125 | } else {
|
|---|
| 126 | print "not ok $realtest\n";
|
|---|
| 127 | }
|
|---|
| 128 | $realtest++;
|
|---|
| 129 |
|
|---|
| 130 | my @makeout;
|
|---|
| 131 |
|
|---|
| 132 | if ($^O eq 'VMS') { $make .= ' all'; }
|
|---|
| 133 |
|
|---|
| 134 | # Sometimes it seems that timestamps can get confused
|
|---|
| 135 |
|
|---|
| 136 | # make failed: 256
|
|---|
| 137 | # Makefile out-of-date with respect to Makefile.PL
|
|---|
| 138 | # Cleaning current config before rebuilding Makefile...
|
|---|
| 139 | # make -f Makefile.old clean > /dev/null 2>&1 || /bin/sh -c true
|
|---|
| 140 | # ../../perl "-I../../../lib" "-I../../../lib" Makefile.PL "PERL_CORE=1"
|
|---|
| 141 | # Checking if your kit is complete...
|
|---|
| 142 | # Looks good
|
|---|
| 143 | # Writing Makefile for ExtTest
|
|---|
| 144 | # ==> Your Makefile has been rebuilt. <==
|
|---|
| 145 | # ==> Please rerun the make command. <==
|
|---|
| 146 | # false
|
|---|
| 147 |
|
|---|
| 148 | my $timewarp = (-M "Makefile.PL") - (-M "$makefile$makefile_ext");
|
|---|
| 149 | # Convert from days to seconds
|
|---|
| 150 | $timewarp *= 86400;
|
|---|
| 151 | print "# Makefile.PL is $timewarp second(s) older than $makefile$makefile_ext\n";
|
|---|
| 152 | if ($timewarp < 0) {
|
|---|
| 153 | # Sleep for a while to catch up.
|
|---|
| 154 | $timewarp = -$timewarp;
|
|---|
| 155 | $timewarp+=2;
|
|---|
| 156 | $timewarp = 10 if $timewarp > 10;
|
|---|
| 157 | print "# Sleeping for $timewarp second(s) to try to resolve this\n";
|
|---|
| 158 | sleep $timewarp;
|
|---|
| 159 | }
|
|---|
| 160 |
|
|---|
| 161 | print "# make = '$make'\n";
|
|---|
| 162 | @makeout = `$make`;
|
|---|
| 163 | if ($?) {
|
|---|
| 164 | print "not ok $realtest # $make failed: $?\n";
|
|---|
| 165 | print "# $_" foreach @makeout;
|
|---|
| 166 | exit($?);
|
|---|
| 167 | } else {
|
|---|
| 168 | print "ok $realtest\n";
|
|---|
| 169 | }
|
|---|
| 170 | $realtest++;
|
|---|
| 171 |
|
|---|
| 172 | if ($^O eq 'VMS') { $make =~ s{ all}{}; }
|
|---|
| 173 |
|
|---|
| 174 | if ($Config{usedl}) {
|
|---|
| 175 | print "ok $realtest # This is dynamic linking, so no need to make perl\n";
|
|---|
| 176 | } else {
|
|---|
| 177 | my $makeperl = "$make perl";
|
|---|
| 178 | print "# make = '$makeperl'\n";
|
|---|
| 179 | @makeout = `$makeperl`;
|
|---|
| 180 | if ($?) {
|
|---|
| 181 | print "not ok $realtest # $makeperl failed: $?\n";
|
|---|
| 182 | print "# $_" foreach @makeout;
|
|---|
| 183 | exit($?);
|
|---|
| 184 | } else {
|
|---|
| 185 | print "ok $realtest\n";
|
|---|
| 186 | }
|
|---|
| 187 | }
|
|---|
| 188 | $realtest++;
|
|---|
| 189 |
|
|---|
| 190 | my $maketest = "$make test";
|
|---|
| 191 | print "# make = '$maketest'\n";
|
|---|
| 192 |
|
|---|
| 193 | @makeout = `$maketest`;
|
|---|
| 194 |
|
|---|
| 195 | if (open OUTPUT, "<$output") {
|
|---|
| 196 | local $/; # Slurp it - faster.
|
|---|
| 197 | print <OUTPUT>;
|
|---|
| 198 | close OUTPUT or print "# Close $output failed: $!\n";
|
|---|
| 199 | } else {
|
|---|
| 200 | # Harness will report missing test results at this point.
|
|---|
| 201 | print "# Open <$output failed: $!\n";
|
|---|
| 202 | }
|
|---|
| 203 |
|
|---|
| 204 | $realtest += $tests;
|
|---|
| 205 | if ($?) {
|
|---|
| 206 | print "not ok $realtest # $maketest failed: $?\n";
|
|---|
| 207 | print "# $_" foreach @makeout;
|
|---|
| 208 | } else {
|
|---|
| 209 | print "ok $realtest - maketest\n";
|
|---|
| 210 | }
|
|---|
| 211 | $realtest++;
|
|---|
| 212 |
|
|---|
| 213 | # -x is busted on Win32 < 5.6.1, so we emulate it.
|
|---|
| 214 | my $regen;
|
|---|
| 215 | if( $^O eq 'MSWin32' && $] <= 5.006001 ) {
|
|---|
| 216 | open(REGENTMP, ">regentmp") or die $!;
|
|---|
| 217 | open(XS, "$package.xs") or die $!;
|
|---|
| 218 | my $saw_shebang;
|
|---|
| 219 | while(<XS>) {
|
|---|
| 220 | $saw_shebang++ if /^#!.*/i ;
|
|---|
| 221 | print REGENTMP $_ if $saw_shebang;
|
|---|
| 222 | }
|
|---|
| 223 | close XS; close REGENTMP;
|
|---|
| 224 | $regen = `$runperl regentmp`;
|
|---|
| 225 | unlink 'regentmp';
|
|---|
| 226 | }
|
|---|
| 227 | else {
|
|---|
| 228 | $regen = `$runperl -x $package.xs`;
|
|---|
| 229 | }
|
|---|
| 230 | if ($?) {
|
|---|
| 231 | print "not ok $realtest # $runperl -x $package.xs failed: $?\n";
|
|---|
| 232 | } else {
|
|---|
| 233 | print "ok $realtest - regen\n";
|
|---|
| 234 | }
|
|---|
| 235 | $realtest++;
|
|---|
| 236 |
|
|---|
| 237 | if ($expect eq $regen) {
|
|---|
| 238 | print "ok $realtest - regen worked\n";
|
|---|
| 239 | } else {
|
|---|
| 240 | print "not ok $realtest - regen worked\n";
|
|---|
| 241 | # open FOO, ">expect"; print FOO $expect;
|
|---|
| 242 | # open FOO, ">regen"; print FOO $regen; close FOO;
|
|---|
| 243 | }
|
|---|
| 244 | $realtest++;
|
|---|
| 245 |
|
|---|
| 246 | my $makeclean = "$make clean";
|
|---|
| 247 | print "# make = '$makeclean'\n";
|
|---|
| 248 | @makeout = `$makeclean`;
|
|---|
| 249 | if ($?) {
|
|---|
| 250 | print "not ok $realtest # $make failed: $?\n";
|
|---|
| 251 | print "# $_" foreach @makeout;
|
|---|
| 252 | } else {
|
|---|
| 253 | print "ok $realtest\n";
|
|---|
| 254 | }
|
|---|
| 255 | $realtest++;
|
|---|
| 256 |
|
|---|
| 257 | check_for_bonus_files ('.', @$files, $output, $makefile_rename, '.', '..');
|
|---|
| 258 |
|
|---|
| 259 | rename $makefile_rename, $makefile . $makefile_ext
|
|---|
| 260 | or die "Can't rename '$makefile_rename' to '$makefile$makefile_ext': $!";
|
|---|
| 261 |
|
|---|
| 262 | unlink $output or warn "Can't unlink '$output': $!";
|
|---|
| 263 |
|
|---|
| 264 | # Need to make distclean to remove ../../lib/ExtTest.pm
|
|---|
| 265 | my $makedistclean = "$make distclean";
|
|---|
| 266 | print "# make = '$makedistclean'\n";
|
|---|
| 267 | @makeout = `$makedistclean`;
|
|---|
| 268 | if ($?) {
|
|---|
| 269 | print "not ok $realtest # $make failed: $?\n";
|
|---|
| 270 | print "# $_" foreach @makeout;
|
|---|
| 271 | } else {
|
|---|
| 272 | print "ok $realtest\n";
|
|---|
| 273 | }
|
|---|
| 274 | $realtest++;
|
|---|
| 275 |
|
|---|
| 276 | check_for_bonus_files ('.', @$files, '.', '..');
|
|---|
| 277 |
|
|---|
| 278 | unless ($keep_files) {
|
|---|
| 279 | foreach (@$files) {
|
|---|
| 280 | unlink $_ or warn "unlink $_: $!";
|
|---|
| 281 | }
|
|---|
| 282 | }
|
|---|
| 283 |
|
|---|
| 284 | check_for_bonus_files ('.', '.', '..');
|
|---|
| 285 | }
|
|---|
| 286 |
|
|---|
| 287 | sub Makefile_PL {
|
|---|
| 288 | my $package = shift;
|
|---|
| 289 | ################ Makefile.PL
|
|---|
| 290 | # We really need a Makefile.PL because make test for a no dynamic linking perl
|
|---|
| 291 | # will run Makefile.PL again as part of the "make perl" target.
|
|---|
| 292 | my $makefilePL = "Makefile.PL";
|
|---|
| 293 | open FH, ">$makefilePL" or die "open >$makefilePL: $!\n";
|
|---|
| 294 | print FH <<"EOT";
|
|---|
| 295 | #!$perl -w
|
|---|
| 296 | use ExtUtils::MakeMaker;
|
|---|
| 297 | WriteMakefile(
|
|---|
| 298 | 'NAME' => "$package",
|
|---|
| 299 | 'VERSION_FROM' => "$package.pm", # finds \$VERSION
|
|---|
| 300 | (\$] >= 5.005 ?
|
|---|
| 301 | (#ABSTRACT_FROM => "$package.pm", # XXX add this
|
|---|
| 302 | AUTHOR => "$0") : ())
|
|---|
| 303 | );
|
|---|
| 304 | EOT
|
|---|
| 305 |
|
|---|
| 306 | close FH or die "close $makefilePL: $!\n";
|
|---|
| 307 | return $makefilePL;
|
|---|
| 308 | }
|
|---|
| 309 |
|
|---|
| 310 | sub MANIFEST {
|
|---|
| 311 | my (@files) = @_;
|
|---|
| 312 | ################ MANIFEST
|
|---|
| 313 | # We really need a MANIFEST because make distclean checks it.
|
|---|
| 314 | my $manifest = "MANIFEST";
|
|---|
| 315 | push @files, $manifest;
|
|---|
| 316 | open FH, ">$manifest" or die "open >$manifest: $!\n";
|
|---|
| 317 | print FH "$_\n" foreach @files;
|
|---|
| 318 | close FH or die "close $manifest: $!\n";
|
|---|
| 319 | return @files;
|
|---|
| 320 | }
|
|---|
| 321 |
|
|---|
| 322 | sub write_and_run_extension {
|
|---|
| 323 | my ($name, $items, $export_names, $package, $header, $testfile, $num_tests)
|
|---|
| 324 | = @_;
|
|---|
| 325 | my $types = {};
|
|---|
| 326 | my $constant_types = constant_types(); # macro defs
|
|---|
| 327 | my $C_constant = join "\n",
|
|---|
| 328 | C_constant ($package, undef, "IV", $types, undef, undef, @$items);
|
|---|
| 329 | my $XS_constant = XS_constant ($package, $types); # XS for ExtTest::constant
|
|---|
| 330 |
|
|---|
| 331 | my $expect = $constant_types . $C_constant .
|
|---|
| 332 | "\n#### XS Section:\n" . $XS_constant;
|
|---|
| 333 |
|
|---|
| 334 | print "# $name\n# $dir/$subdir being created...\n";
|
|---|
| 335 | mkdir $subdir, 0777 or die "mkdir: $!\n";
|
|---|
| 336 | chdir $subdir or die $!;
|
|---|
| 337 |
|
|---|
| 338 | my @files;
|
|---|
| 339 |
|
|---|
| 340 | ################ Header
|
|---|
| 341 | my $header_name = "test.h";
|
|---|
| 342 | push @files, $header_name;
|
|---|
| 343 | open FH, ">$header_name" or die "open >$header_name: $!\n";
|
|---|
| 344 | print FH $header or die $!;
|
|---|
| 345 | close FH or die "close $header_name: $!\n";
|
|---|
| 346 |
|
|---|
| 347 | ################ XS
|
|---|
| 348 | my $xs = "$package.xs";
|
|---|
| 349 | push @files, $xs;
|
|---|
| 350 | open FH, ">$xs" or die "open >$xs: $!\n";
|
|---|
| 351 |
|
|---|
| 352 | print FH <<'EOT';
|
|---|
| 353 | #include "EXTERN.h"
|
|---|
| 354 | #include "perl.h"
|
|---|
| 355 | #include "XSUB.h"
|
|---|
| 356 | EOT
|
|---|
| 357 |
|
|---|
| 358 | # XXX Here doc these:
|
|---|
| 359 | print FH "#include \"$header_name\"\n\n";
|
|---|
| 360 | print FH $constant_types;
|
|---|
| 361 | print FH $C_constant, "\n";
|
|---|
| 362 | print FH "MODULE = $package PACKAGE = $package\n";
|
|---|
| 363 | print FH "PROTOTYPES: ENABLE\n";
|
|---|
| 364 | print FH $XS_constant;
|
|---|
| 365 | close FH or die "close $xs: $!\n";
|
|---|
| 366 |
|
|---|
| 367 | ################ PM
|
|---|
| 368 | my $pm = "$package.pm";
|
|---|
| 369 | push @files, $pm;
|
|---|
| 370 | open FH, ">$pm" or die "open >$pm: $!\n";
|
|---|
| 371 | print FH "package $package;\n";
|
|---|
| 372 | print FH "use $];\n";
|
|---|
| 373 |
|
|---|
| 374 | print FH <<'EOT';
|
|---|
| 375 |
|
|---|
| 376 | use strict;
|
|---|
| 377 | EOT
|
|---|
| 378 | printf FH "use warnings;\n" unless $] < 5.006;
|
|---|
| 379 | print FH <<'EOT';
|
|---|
| 380 | use Carp;
|
|---|
| 381 |
|
|---|
| 382 | require Exporter;
|
|---|
| 383 | require DynaLoader;
|
|---|
| 384 | use vars qw ($VERSION @ISA @EXPORT_OK $AUTOLOAD);
|
|---|
| 385 |
|
|---|
| 386 | $VERSION = '0.01';
|
|---|
| 387 | @ISA = qw(Exporter DynaLoader);
|
|---|
| 388 | EOT
|
|---|
| 389 | # Having this qw( in the here doc confuses cperl mode far too much to be
|
|---|
| 390 | # helpful. And I'm using cperl mode to edit this, even if you're not :-)
|
|---|
| 391 | print FH "\@EXPORT_OK = qw(\n";
|
|---|
| 392 |
|
|---|
| 393 | # Print the names of all our autoloaded constants
|
|---|
| 394 | print FH "\t$_\n" foreach (@$export_names);
|
|---|
| 395 | print FH ");\n";
|
|---|
| 396 | # Print the AUTOLOAD subroutine ExtUtils::Constant generated for us
|
|---|
| 397 | print FH autoload ($package, $]);
|
|---|
| 398 | print FH "bootstrap $package \$VERSION;\n1;\n__END__\n";
|
|---|
| 399 | close FH or die "close $pm: $!\n";
|
|---|
| 400 |
|
|---|
| 401 | ################ test.pl
|
|---|
| 402 | my $testpl = "test.pl";
|
|---|
| 403 | push @files, $testpl;
|
|---|
| 404 | open FH, ">$testpl" or die "open >$testpl: $!\n";
|
|---|
| 405 | # Standard test header (need an option to suppress this?)
|
|---|
| 406 | print FH <<"EOT" or die $!;
|
|---|
| 407 | use strict;
|
|---|
| 408 | use $package qw(@$export_names);
|
|---|
| 409 |
|
|---|
| 410 | print "1..2\n";
|
|---|
| 411 | if (open OUTPUT, ">$output") {
|
|---|
| 412 | print "ok 1\n";
|
|---|
| 413 | select OUTPUT;
|
|---|
| 414 | } else {
|
|---|
| 415 | print "not ok 1 # Failed to open '$output': \$!\n";
|
|---|
| 416 | exit 1;
|
|---|
| 417 | }
|
|---|
| 418 | EOT
|
|---|
| 419 | print FH $testfile or die $!;
|
|---|
| 420 | print FH <<"EOT" or die $!;
|
|---|
| 421 | select STDOUT;
|
|---|
| 422 | if (close OUTPUT) {
|
|---|
| 423 | print "ok 2\n";
|
|---|
| 424 | } else {
|
|---|
| 425 | print "not ok 2 # Failed to close '$output': \$!\n";
|
|---|
| 426 | }
|
|---|
| 427 | EOT
|
|---|
| 428 | close FH or die "close $testpl: $!\n";
|
|---|
| 429 |
|
|---|
| 430 | push @files, Makefile_PL($package);
|
|---|
| 431 | @files = MANIFEST (@files);
|
|---|
| 432 |
|
|---|
| 433 | build_and_run ($num_tests, $expect, \@files);
|
|---|
| 434 |
|
|---|
| 435 | chdir $updir or die "chdir '$updir': $!";
|
|---|
| 436 | ++$subdir;
|
|---|
| 437 | }
|
|---|
| 438 | # Tests are arrayrefs of the form
|
|---|
| 439 | # $name, [items], [export_names], $package, $header, $testfile, $num_tests
|
|---|
| 440 | my @tests;
|
|---|
| 441 | my $before_tests = 4; # Number of "ok"s emitted to build extension
|
|---|
| 442 | my $after_tests = 8; # Number of "ok"s emitted after make test run
|
|---|
| 443 | my $dummytest = 1;
|
|---|
| 444 |
|
|---|
| 445 | my $here;
|
|---|
| 446 | sub start_tests {
|
|---|
| 447 | $dummytest += $before_tests;
|
|---|
| 448 | $here = $dummytest;
|
|---|
| 449 | }
|
|---|
| 450 | sub end_tests {
|
|---|
| 451 | my ($name, $items, $export_names, $header, $testfile) = @_;
|
|---|
| 452 | push @tests, [$name, $items, $export_names, $package, $header, $testfile,
|
|---|
| 453 | $dummytest - $here];
|
|---|
| 454 | $dummytest += $after_tests;
|
|---|
| 455 | }
|
|---|
| 456 |
|
|---|
| 457 | my $pound;
|
|---|
| 458 | if (ord('A') == 193) { # EBCDIC platform
|
|---|
| 459 | $pound = chr 177; # A pound sign. (Currency)
|
|---|
| 460 | } else { # ASCII platform
|
|---|
| 461 | $pound = chr 163; # A pound sign. (Currency)
|
|---|
| 462 | }
|
|---|
| 463 | my @common_items = (
|
|---|
| 464 | {name=>"perl", type=>"PV",},
|
|---|
| 465 | {name=>"*/", type=>"PV", value=>'"CLOSE"', macro=>1},
|
|---|
| 466 | {name=>"/*", type=>"PV", value=>'"OPEN"', macro=>1},
|
|---|
| 467 | {name=>$pound, type=>"PV", value=>'"Sterling"', macro=>1},
|
|---|
| 468 | );
|
|---|
| 469 |
|
|---|
| 470 | {
|
|---|
| 471 | # Simple tests
|
|---|
| 472 | start_tests();
|
|---|
| 473 | my $parent_rfc1149 =
|
|---|
| 474 | 'A Standard for the Transmission of IP Datagrams on Avian Carriers';
|
|---|
| 475 | # Test the code that generates 1 and 2 letter name comparisons.
|
|---|
| 476 | my %compass = (
|
|---|
| 477 | N => 0, 'NE' => 45, E => 90, SE => 135,
|
|---|
| 478 | S => 180, SW => 225, W => 270, NW => 315
|
|---|
| 479 | );
|
|---|
| 480 |
|
|---|
| 481 | my $header = << "EOT";
|
|---|
| 482 | #define FIVE 5
|
|---|
| 483 | #define OK6 "ok 6\\n"
|
|---|
| 484 | #define OK7 1
|
|---|
| 485 | #define FARTHING 0.25
|
|---|
| 486 | #define NOT_ZERO 1
|
|---|
| 487 | #define Yes 0
|
|---|
| 488 | #define No 1
|
|---|
| 489 | #define Undef 1
|
|---|
| 490 | #define RFC1149 "$parent_rfc1149"
|
|---|
| 491 | #undef NOTDEF
|
|---|
| 492 | #define perl "rules"
|
|---|
| 493 | EOT
|
|---|
| 494 |
|
|---|
| 495 | while (my ($point, $bearing) = each %compass) {
|
|---|
| 496 | $header .= "#define $point $bearing\n"
|
|---|
| 497 | }
|
|---|
| 498 |
|
|---|
| 499 | my @items = ("FIVE", {name=>"OK6", type=>"PV",},
|
|---|
| 500 | {name=>"OK7", type=>"PVN",
|
|---|
| 501 | value=>['"not ok 7\\n\\0ok 7\\n"', 15]},
|
|---|
| 502 | {name => "FARTHING", type=>"NV"},
|
|---|
| 503 | {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"},
|
|---|
| 504 | {name => "OPEN", type=>"PV", value=>'"/*"', macro=>1},
|
|---|
| 505 | {name => "CLOSE", type=>"PV", value=>'"*/"',
|
|---|
| 506 | macro=>["#if 1\n", "#endif\n"]},
|
|---|
| 507 | {name => "ANSWER", default=>["UV", 42]}, "NOTDEF",
|
|---|
| 508 | {name => "Yes", type=>"YES"},
|
|---|
| 509 | {name => "No", type=>"NO"},
|
|---|
| 510 | {name => "Undef", type=>"UNDEF"},
|
|---|
| 511 | # OK. It wasn't really designed to allow the creation of dual valued
|
|---|
| 512 | # constants.
|
|---|
| 513 | # It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
|
|---|
| 514 | {name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)",
|
|---|
| 515 | pre=>"SV *temp_sv = newSVpv(RFC1149, 0); "
|
|---|
| 516 | . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); "
|
|---|
| 517 | . "SvIV_set(temp_sv, 1149);"},
|
|---|
| 518 | );
|
|---|
| 519 |
|
|---|
| 520 | push @items, $_ foreach keys %compass;
|
|---|
| 521 |
|
|---|
| 522 | # Automatically compile the list of all the macro names, and make them
|
|---|
| 523 | # exported constants.
|
|---|
| 524 | my @export_names = map {(ref $_) ? $_->{name} : $_} @items;
|
|---|
| 525 |
|
|---|
| 526 | # Exporter::Heavy (currently) isn't able to export the last 3 of these:
|
|---|
| 527 | push @items, @common_items;
|
|---|
| 528 |
|
|---|
| 529 | # XXX there are hardwired still.
|
|---|
| 530 | my $test_body = <<'EOT';
|
|---|
| 531 | # What follows goes to the temporary file.
|
|---|
| 532 | # IV
|
|---|
| 533 | my $five = FIVE;
|
|---|
| 534 | if ($five == 5) {
|
|---|
| 535 | print "ok 5\n";
|
|---|
| 536 | } else {
|
|---|
| 537 | print "not ok 5 # \$five\n";
|
|---|
| 538 | }
|
|---|
| 539 |
|
|---|
| 540 | # PV
|
|---|
| 541 | print OK6;
|
|---|
| 542 |
|
|---|
| 543 | # PVN containing embedded \0s
|
|---|
| 544 | $_ = OK7;
|
|---|
| 545 | s/.*\0//s;
|
|---|
| 546 | print;
|
|---|
| 547 |
|
|---|
| 548 | # NV
|
|---|
| 549 | my $farthing = FARTHING;
|
|---|
| 550 | if ($farthing == 0.25) {
|
|---|
| 551 | print "ok 8\n";
|
|---|
| 552 | } else {
|
|---|
| 553 | print "not ok 8 # $farthing\n";
|
|---|
| 554 | }
|
|---|
| 555 |
|
|---|
| 556 | # UV
|
|---|
| 557 | my $not_zero = NOT_ZERO;
|
|---|
| 558 | if ($not_zero > 0 && $not_zero == ~0) {
|
|---|
| 559 | print "ok 9\n";
|
|---|
| 560 | } else {
|
|---|
| 561 | print "not ok 9 # \$not_zero=$not_zero ~0=" . (~0) . "\n";
|
|---|
| 562 | }
|
|---|
| 563 |
|
|---|
| 564 | # Value includes a "*/" in an attempt to bust out of a C comment.
|
|---|
| 565 | # Also tests custom cpp #if clauses
|
|---|
| 566 | my $close = CLOSE;
|
|---|
| 567 | if ($close eq '*/') {
|
|---|
| 568 | print "ok 10\n";
|
|---|
| 569 | } else {
|
|---|
| 570 | print "not ok 10 # \$close='$close'\n";
|
|---|
| 571 | }
|
|---|
| 572 |
|
|---|
| 573 | # Default values if macro not defined.
|
|---|
| 574 | my $answer = ANSWER;
|
|---|
| 575 | if ($answer == 42) {
|
|---|
| 576 | print "ok 11\n";
|
|---|
| 577 | } else {
|
|---|
| 578 | print "not ok 11 # What do you get if you multiply six by nine? '$answer'\n";
|
|---|
| 579 | }
|
|---|
| 580 |
|
|---|
| 581 | # not defined macro
|
|---|
| 582 | my $notdef = eval { NOTDEF; };
|
|---|
| 583 | if (defined $notdef) {
|
|---|
| 584 | print "not ok 12 # \$notdef='$notdef'\n";
|
|---|
| 585 | } elsif ($@ !~ /Your vendor has not defined ExtTest macro NOTDEF/) {
|
|---|
| 586 | print "not ok 12 # \$@='$@'\n";
|
|---|
| 587 | } else {
|
|---|
|
|---|
