xref: /openbsd-src/gnu/usr.bin/perl/cpan/ExtUtils-Constant/t/Constant.t (revision d13be5d47e4149db2549a9828e244d59dbc43f15) 
1#!/usr/bin/perl -w
2
3use Config;
4unless ($Config{usedl}) {
5    print "1..0 # no usedl, skipping\n";
6    exit 0;
7}
8
9# use warnings;
10use strict;
11use ExtUtils::MakeMaker;
12use ExtUtils::Constant qw (C_constant autoload);
13use File::Spec;
14use Cwd;
15
16my $do_utf_tests = $] > 5.006;
17my $better_than_56 = $] > 5.007;
18# For debugging set this to 1.
19my $keep_files = 0;
20$| = 1;
21
22# Because were are going to be changing directory before running Makefile.PL
23my $perl = $^X;
24# 5.005 doesn't have new enough File::Spec to have rel2abs. But actually we
25# only need it when $^X isn't absolute, which is going to be 5.8.0 or later
26# (where ExtUtils::Constant is in the core, and tests against the uninstalled
27# perl)
28$perl = File::Spec->rel2abs ($perl) unless $] < 5.006;
29# ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to
30# compare output to ensure that it is the same. We were probably run as ./perl
31# whereas we will run the child with the full path in $perl. So make $^X for
32# us the same as our child will see.
33$^X = $perl;
34my $lib = $ENV{PERL_CORE} ? '../../../lib' : '../../blib/lib';
35my $runperl = "$perl \"-I$lib\"";
36print "# perl=$perl\n";
37
38my $make = $Config{make};
39$make = $ENV{MAKE} if exists $ENV{MAKE};
40if ($^O eq 'MSWin32' && $make eq 'nmake') { $make .= " -nologo"; }
41
42# VMS may be using something other than MMS/MMK
43my $mms_or_mmk = 0;
44my $vms_lc = 0;
45my $vms_nodot = 0;
46if ($^O eq 'VMS') {
47    $mms_or_mmk = 1 if (($make eq 'MMK') || ($make eq 'MMS'));
48    $vms_lc = 1;
49    $vms_nodot = 1;
50    my $vms_unix_rpt = 0;
51    my $vms_efs = 0;
52    my $vms_efs_case = 0;
53    if (eval 'require VMS::Feature') {
54        $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
55        $vms_efs = VMS::Feature::current("efs_case_preserve");
56        $vms_efs_case = VMS::Feature::current("efs_charset");
57    } else {
58        my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
59        my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
60        my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
61        $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
62        $vms_efs = $efs_charset =~ /^[ET1]/i;
63        $vms_efs_case = $efs_case =~ /^[ET1]/i;
64    }
65    $vms_lc = 0 if $vms_efs_case;
66    $vms_nodot = 0 if $vms_unix_rpt;
67}
68
69# Renamed by make clean
70my $makefile = ($mms_or_mmk ? 'descrip' : 'Makefile');
71my $makefile_ext = ($mms_or_mmk ? '.mms' : '');
72my $makefile_rename = $makefile . ($mms_or_mmk ? '.mms_old' : '.old');
73
74my $output = "output";
75my $package = "ExtTest";
76my $dir = "ext-$$";
77my $subdir = 0;
78# The real test counter.
79my $realtest = 1;
80
81my $orig_cwd = cwd;
82my $updir = File::Spec->updir;
83die "Can't get current directory: $!" unless defined $orig_cwd;
84
85print "# $dir being created...\n";
86mkdir $dir, 0777 or die "mkdir: $!\n";
87
88END {
89  if (defined $orig_cwd and length $orig_cwd) {
90    chdir $orig_cwd or die "Can't chdir back to '$orig_cwd': $!";
91    use File::Path;
92    print "# $dir being removed...\n";
93    rmtree($dir) unless $keep_files;
94  } else {
95    # Can't get here.
96    die "cwd at start was empty, but directory '$dir' was created" if $dir;
97  }
98}
99
100chdir $dir or die $!;
101push @INC, '../../lib', '../../../lib';
102
103package TieOut;
104
105sub TIEHANDLE {
106    my $class = shift;
107    bless(\( my $ref = ''), $class);
108}
109
110sub PRINT {
111    my $self = shift;
112    $$self .= join('', @_);
113}
114
115sub PRINTF {
116    my $self = shift;
117    $$self .= sprintf shift, @_;
118}
119
120sub read {
121    my $self = shift;
122    return substr($$self, 0, length($$self), '');
123}
124
125package main;
126
127sub check_for_bonus_files {
128  my $dir = shift;
129  my %expect = map {($vms_lc ? lc($_) : $_), 1} @_;
130
131  my $fail;
132  opendir DIR, $dir or die "opendir '$dir': $!";
133  while (defined (my $entry = readdir DIR)) {
134    $entry =~ s/\.$// if $vms_nodot;  # delete trailing dot that indicates no extension
135    next if $expect{$entry};
136    print "# Extra file '$entry'\n";
137    $fail = 1;
138  }
139
140  closedir DIR or warn "closedir '.': $!";
141  if ($fail) {
142    print "not ok $realtest\n";
143  } else {
144    print "ok $realtest\n";
145  }
146  $realtest++;
147}
148
149sub build_and_run {
150  my ($tests, $expect, $files) = @_;
151  my $core = $ENV{PERL_CORE} ? ' PERL_CORE=1' : '';
152  my @perlout = `$runperl Makefile.PL $core`;
153  if ($?) {
154    print "not ok $realtest # $runperl Makefile.PL failed: $?\n";
155    print "# $_" foreach @perlout;
156    exit($?);
157  } else {
158    print "ok $realtest\n";
159  }
160  $realtest++;
161
162  if (-f "$makefile$makefile_ext") {
163    print "ok $realtest\n";
164  } else {
165    print "not ok $realtest\n";
166  }
167  $realtest++;
168
169  my @makeout;
170
171  if ($^O eq 'VMS') { $make .= ' all'; }
172
173  # Sometimes it seems that timestamps can get confused
174
175  # make failed: 256
176  # Makefile out-of-date with respect to Makefile.PL
177  # Cleaning current config before rebuilding Makefile...
178  # make -f Makefile.old clean > /dev/null 2>&1 || /bin/sh -c true
179  # ../../perl "-I../../../lib" "-I../../../lib" Makefile.PL "PERL_CORE=1"
180  # Checking if your kit is complete...
181  # Looks good
182  # Writing Makefile for ExtTest
183  # ==> Your Makefile has been rebuilt. <==
184  # ==> Please rerun the make command.  <==
185  # false
186
187  my $timewarp = (-M "Makefile.PL") - (-M "$makefile$makefile_ext");
188  # Convert from days to seconds
189  $timewarp *= 86400;
190  print "# Makefile.PL is $timewarp second(s) older than $makefile$makefile_ext\n";
191  if ($timewarp < 0) {
192      # Sleep for a while to catch up.
193      $timewarp = -$timewarp;
194      $timewarp+=2;
195      $timewarp = 10 if $timewarp > 10;
196      print "# Sleeping for $timewarp second(s) to try to resolve this\n";
197      sleep $timewarp;
198  }
199
200  print "# make = '$make'\n";
201  @makeout = `$make`;
202  if ($?) {
203    print "not ok $realtest # $make failed: $?\n";
204    print "# $_" foreach @makeout;
205    exit($?);
206  } else {
207    print "ok $realtest\n";
208  }
209  $realtest++;
210
211  if ($^O eq 'VMS') { $make =~ s{ all}{}; }
212
213  if ($Config{usedl}) {
214    print "ok $realtest # This is dynamic linking, so no need to make perl\n";
215  } else {
216    my $makeperl = "$make perl";
217    print "# make = '$makeperl'\n";
218    @makeout = `$makeperl`;
219    if ($?) {
220      print "not ok $realtest # $makeperl failed: $?\n";
221      print "# $_" foreach @makeout;
222      exit($?);
223    } else {
224      print "ok $realtest\n";
225    }
226  }
227  $realtest++;
228
229  my $maketest = "$make test";
230  print "# make = '$maketest'\n";
231
232  @makeout = `$maketest`;
233
234  if (open OUTPUT, "<$output") {
235    local $/; # Slurp it - faster.
236    print <OUTPUT>;
237    close OUTPUT or print "# Close $output failed: $!\n";
238  } else {
239    # Harness will report missing test results at this point.
240    print "# Open <$output failed: $!\n";
241  }
242
243  $realtest += $tests;
244  if ($?) {
245    print "not ok $realtest # $maketest failed: $?\n";
246    print "# $_" foreach @makeout;
247  } else {
248    print "ok $realtest - maketest\n";
249  }
250  $realtest++;
251
252  if (defined $expect) {
253      # -x is busted on Win32 < 5.6.1, so we emulate it.
254      my $regen;
255      if( $^O eq 'MSWin32' && $] <= 5.006001 ) {
256	  open(REGENTMP, ">regentmp") or die $!;
257	  open(XS, "$package.xs")     or die $!;
258	  my $saw_shebang;
259	  while(<XS>) {
260	      $saw_shebang++ if /^#!.*/i ;
261	      print REGENTMP $_ if $saw_shebang;
262	  }
263	  close XS;  close REGENTMP;
264	  $regen = `$runperl regentmp`;
265	  unlink 'regentmp';
266      }
267      else {
268	  $regen = `$runperl -x $package.xs`;
269      }
270      if ($?) {
271	  print "not ok $realtest # $runperl -x $package.xs failed: $?\n";
272	  } else {
273	      print "ok $realtest - regen\n";
274	  }
275      $realtest++;
276
277      if ($expect eq $regen) {
278	  print "ok $realtest - regen worked\n";
279      } else {
280	  print "not ok $realtest - regen worked\n";
281	  # open FOO, ">expect"; print FOO $expect;
282	  # open FOO, ">regen"; print FOO $regen; close FOO;
283      }
284      $realtest++;
285  } else {
286    for (0..1) {
287      print "ok $realtest # skip no regen or expect for this set of tests\n";
288      $realtest++;
289    }
290  }
291
292  my $makeclean = "$make clean";
293  print "# make = '$makeclean'\n";
294  @makeout = `$makeclean`;
295  if ($?) {
296    print "not ok $realtest # $make failed: $?\n";
297    print "# $_" foreach @makeout;
298  } else {
299    print "ok $realtest\n";
300  }
301  $realtest++;
302
303  check_for_bonus_files ('.', @$files, $output, $makefile_rename, '.', '..');
304
305  rename $makefile_rename, $makefile . $makefile_ext
306    or die "Can't rename '$makefile_rename' to '$makefile$makefile_ext': $!";
307
308  unlink $output or warn "Can't unlink '$output': $!";
309
310  # Need to make distclean to remove ../../lib/ExtTest.pm
311  my $makedistclean = "$make distclean";
312  print "# make = '$makedistclean'\n";
313  @makeout = `$makedistclean`;
314  if ($?) {
315    print "not ok $realtest # $make failed: $?\n";
316    print "# $_" foreach @makeout;
317  } else {
318    print "ok $realtest\n";
319  }
320  $realtest++;
321
322  check_for_bonus_files ('.', @$files, '.', '..');
323
324  unless ($keep_files) {
325    foreach (@$files) {
326      unlink $_ or warn "unlink $_: $!";
327    }
328  }
329
330  check_for_bonus_files ('.', '.', '..');
331}
332
333sub Makefile_PL {
334  my $package = shift;
335  ################ Makefile.PL
336  # We really need a Makefile.PL because make test for a no dynamic linking perl
337  # will run Makefile.PL again as part of the "make perl" target.
338  my $makefilePL = "Makefile.PL";
339  open FH, ">$makefilePL" or die "open >$makefilePL: $!\n";
340  print FH <<"EOT";
341#!$perl -w
342use ExtUtils::MakeMaker;
343WriteMakefile(
344              'NAME'		=> "$package",
345              'VERSION_FROM'	=> "$package.pm", # finds \$VERSION
346              (\$] >= 5.005 ?
347               (#ABSTRACT_FROM => "$package.pm", # XXX add this
348                AUTHOR     => "$0") : ())
349             );
350EOT
351
352  close FH or die "close $makefilePL: $!\n";
353  return $makefilePL;
354}
355
356sub MANIFEST {
357  my (@files) = @_;
358  ################ MANIFEST
359  # We really need a MANIFEST because make distclean checks it.
360  my $manifest = "MANIFEST";
361  push @files, $manifest;
362  open FH, ">$manifest" or die "open >$manifest: $!\n";
363  print FH "$_\n" foreach @files;
364  close FH or die "close $manifest: $!\n";
365  return @files;
366}
367
368sub write_and_run_extension {
369  my ($name, $items, $export_names, $package, $header, $testfile, $num_tests,
370      $wc_args) = @_;
371
372  my $c = tie *C, 'TieOut';
373  my $xs = tie *XS, 'TieOut';
374
375  ExtUtils::Constant::WriteConstants(C_FH => \*C,
376				     XS_FH => \*XS,
377				     NAME => $package,
378				     NAMES => $items,
379				     @$wc_args,
380				     );
381
382  my $C_code = $c->read();
383  my $XS_code = $xs->read();
384
385  undef $c;
386  undef $xs;
387
388  untie *C;
389  untie *XS;
390
391  # Don't check the regeneration code if we specify extra arguments to
392  # WriteConstants. (Fix this to give finer grained control if needed)
393  my $expect;
394  $expect = $C_code . "\n#### XS Section:\n" . $XS_code unless $wc_args;
395
396  print "# $name\n# $dir/$subdir being created...\n";
397  mkdir $subdir, 0777 or die "mkdir: $!\n";
398  chdir $subdir or die $!;
399
400  my @files;
401
402  ################ Header
403  my $header_name = "test.h";
404  push @files, $header_name;
405  open FH, ">$header_name" or die "open >$header_name: $!\n";
406  print FH $header or die $!;
407  close FH or die "close $header_name: $!\n";
408
409  ################ XS
410  my $xs_name = "$package.xs";
411  push @files, $xs_name;
412  open FH, ">$xs_name" or die "open >$xs_name: $!\n";
413
414  print FH <<"EOT";
415#include "EXTERN.h"
416#include "perl.h"
417#include "XSUB.h"
418#include "$header_name"
419
420
421$C_code
422MODULE = $package		PACKAGE = $package
423PROTOTYPES: ENABLE
424$XS_code;
425EOT
426
427  close FH or die "close $xs: $!\n";
428
429  ################ PM
430  my $pm = "$package.pm";
431  push @files, $pm;
432  open FH, ">$pm" or die "open >$pm: $!\n";
433  print FH "package $package;\n";
434  print FH "use $];\n";
435
436  print FH <<'EOT';
437
438use strict;
439EOT
440  printf FH "use warnings;\n" unless $] < 5.006;
441  print FH <<'EOT';
442use Carp;
443
444require Exporter;
445require DynaLoader;
446use vars qw ($VERSION @ISA @EXPORT_OK $AUTOLOAD);
447
448$VERSION = '0.01';
449@ISA = qw(Exporter DynaLoader);
450EOT
451  # Having this qw( in the here doc confuses cperl mode far too much to be
452  # helpful. And I'm using cperl mode to edit this, even if you're not :-)
453  print FH "\@EXPORT_OK = qw(\n";
454
455  # Print the names of all our autoloaded constants
456  print FH "\t$_\n" foreach (@$export_names);
457  print FH ");\n";
458  # Print the AUTOLOAD subroutine ExtUtils::Constant generated for us
459  print FH autoload ($package, $]);
460  print FH "bootstrap $package \$VERSION;\n1;\n__END__\n";
461  close FH or die "close $pm: $!\n";
462
463  ################ test.pl
464  my $testpl = "test.pl";
465  push @files, $testpl;
466  open FH, ">$testpl" or die "open >$testpl: $!\n";
467  # Standard test header (need an option to suppress this?)
468  print FH <<"EOT" or die $!;
469use strict;
470use $package qw(@$export_names);
471
472print "1..2\n";
473if (open OUTPUT, ">$output") {
474  print "ok 1\n";
475  select OUTPUT;
476} else {
477  print "not ok 1 # Failed to open '$output': \$!\n";
478  exit 1;
479}
480EOT
481  print FH $testfile or die $!;
482  print FH <<"EOT" or die $!;
483select STDOUT;
484if (close OUTPUT) {
485  print "ok 2\n";
486} else {
487  print "not ok 2 # Failed to close '$output': \$!\n";
488}
489EOT
490  close FH or die "close $testpl: $!\n";
491
492  push @files, Makefile_PL($package);
493  @files = MANIFEST (@files);
494
495  build_and_run ($num_tests, $expect, \@files);
496
497  chdir $updir or die "chdir '$updir': $!";
498  ++$subdir;
499}
500
501# Tests are arrayrefs of the form
502# $name, [items], [export_names], $package, $header, $testfile, $num_tests
503my @tests;
504my $before_tests = 4; # Number of "ok"s emitted to build extension
505my $after_tests = 8; # Number of "ok"s emitted after make test run
506my $dummytest = 1;
507
508my $here;
509sub start_tests {
510  $dummytest += $before_tests;
511  $here = $dummytest;
512}
513sub end_tests {
514  my ($name, $items, $export_names, $header, $testfile, $args) = @_;
515  push @tests, [$name, $items, $export_names, $package, $header, $testfile,
516               $dummytest - $here, $args];
517  $dummytest += $after_tests;
518}
519
520my $pound;
521if (ord('A') == 193) {  # EBCDIC platform
522  $pound = chr 177; # A pound sign. (Currency)
523} else { # ASCII platform
524  $pound = chr 163; # A pound sign. (Currency)
525}
526my @common_items = (
527                    {name=>"perl", type=>"PV",},
528                    {name=>"*/", type=>"PV", value=>'"CLOSE"', macro=>1},
529                    {name=>"/*", type=>"PV", value=>'"OPEN"', macro=>1},
530                    {name=>$pound, type=>"PV", value=>'"Sterling"', macro=>1},
531                   );
532
533my @args = undef;
534push @args, [PROXYSUBS => 1] if $] > 5.009002;
535foreach my $args (@args)
536{
537  # Simple tests
538  start_tests();
539  my $parent_rfc1149 =
540    'A Standard for the Transmission of IP Datagrams on Avian Carriers';
541  # Test the code that generates 1 and 2 letter name comparisons.
542  my %compass = (
543                 N => 0, 'NE' => 45, E => 90, SE => 135,
544                 S => 180, SW => 225, W => 270, NW => 315
545                );
546
547  my $header = << "EOT";
548#define FIVE 5
549#define OK6 "ok 6\\n"
550#define OK7 1
551#define FARTHING 0.25
552#define NOT_ZERO 1
553#define Yes 0
554#define No 1
555#define Undef 1
556#define RFC1149 "$parent_rfc1149"
557#undef NOTDEF
558#define perl "rules"
559EOT
560
561  while (my ($point, $bearing) = each %compass) {
562    $header .= "#define $point $bearing\n"
563  }
564
565  my @items = ("FIVE", {name=>"OK6", type=>"PV",},
566               {name=>"OK7", type=>"PVN",
567                value=>['"not ok 7\\n\\0ok 7\\n"', 15]},
568               {name => "FARTHING", type=>"NV"},
569               {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"},
570               {name => "OPEN", type=>"PV", value=>'"/*"', macro=>1},
571               {name => "CLOSE", type=>"PV", value=>'"*/"',
572                macro=>["#if 1\n", "#endif\n"]},
573               {name => "ANSWER", default=>["UV", 42]}, "NOTDEF",
574               {name => "Yes", type=>"YES"},
575               {name => "No", type=>"NO"},
576               {name => "Undef", type=>"UNDEF"},
577  # OK. It wasn't really designed to allow the creation of dual valued
578  # constants.
579  # It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
580               {name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)",
581                pre=>"SV *temp_sv = newSVpv(RFC1149, 0); "
582                . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); "
583                . "SvIV_set(temp_sv, 1149);"},
584              );
585
586  push @items, $_ foreach keys %compass;
587
588  # Automatically compile the list of all the macro names, and make them
589  # exported constants.
590  my @export_names = map {(ref $_) ? $_->{name} : $_} @items;
591
592  # Exporter::Heavy (currently) isn't able to export the last 3 of these:
593  push @items, @common_items;
594
595  my $test_body = <<"EOT";
596
597my \$test = $dummytest;
598
599EOT
600
601  $test_body .= <<'EOT';
602# What follows goes to the temporary file.
603# IV
604my $five = FIVE;
605if ($five == 5) {
606  print "ok $test\n";
607} else {
608  print "not ok $test # \$five\n";
609}
610$test++;
611
612# PV
613if (OK6 eq "ok 6\n") {
614  print "ok $test\n";
615} else {
616  print "not ok $test # \$five\n";
617}
618$test++;
619
620# PVN containing embedded \0s
621$_ = OK7;
622s/.*\0//s;
623s/7/$test/;
624$test++;
625print;
626
627# NV
628my $farthing = FARTHING;
629if ($farthing == 0.25) {
630  print "ok $test\n";
631} else {
632  print "not ok $test # $farthing\n";
633}
634$test++;
635
636# UV
637my $not_zero = NOT_ZERO;
638if ($not_zero > 0 && $not_zero == ~0) {
639  print "ok $test\n";
640} else {
641  print "not ok $test # \$not_zero=$not_zero ~0=" . (~0) . "\n";
642}
643$test++;
644
645# Value includes a "*/" in an attempt to bust out of a C comment.
646# Also tests custom cpp #if clauses
647my $close = CLOSE;
648if ($close eq '*/') {
649  print "ok $test\n";
650} else {
651  print "not ok $test # \$close='$close'\n";
652}
653$test++;
654
655# Default values if macro not defined.
656my $answer = ANSWER;
657if ($answer == 42) {
658  print "ok $test\n";
659} else {
660  print "not ok $test # What do you get if you multiply six by nine? '$answer'\n";
661}
662$test++;
663
664# not defined macro
665my $notdef = eval { NOTDEF; };
666if (defined $notdef) {
667  print "not ok $test # \$notdef='$notdef'\n";
668} elsif ($@ !~ /Your vendor has not defined ExtTest macro NOTDEF/) {
669  print "not ok $test # \$@='$@'\n";
670} else {
671  print "ok $test\n";
672}
673$test++;
674
675# not a macro
676my $notthere = eval { &ExtTest::NOTTHERE; };
677if (defined $notthere) {
678  print "not ok $test # \$notthere='$notthere'\n";
679} elsif ($@ !~ /NOTTHERE is not a valid ExtTest macro/) {
680  chomp $@;
681  print "not ok $test # \$@='$@'\n";
682} else {
683  print "ok $test\n";
684}
685$test++;
686
687# Truth
688my $yes = Yes;
689if ($yes) {
690  print "ok $test\n";
691} else {
692  print "not ok $test # $yes='\$yes'\n";
693}
694$test++;
695
696# Falsehood
697my $no = No;
698if (defined $no and !$no) {
699  print "ok $test\n";
700} else {
701  print "not ok $test # \$no=" . defined ($no) ? "'$no'\n" : "undef\n";
702}
703$test++;
704
705# Undef
706my $undef = Undef;
707unless (defined $undef) {
708  print "ok $test\n";
709} else {
710  print "not ok $test # \$undef='$undef'\n";
711}
712$test++;
713
714# invalid macro (chosen to look like a mix up between No and SW)
715$notdef = eval { &ExtTest::So };
716if (defined $notdef) {
717  print "not ok $test # \$notdef='$notdef'\n";
718} elsif ($@ !~ /^So is not a valid ExtTest macro/) {
719  print "not ok $test # \$@='$@'\n";
720} else {
721  print "ok $test\n";
722}
723$test++;
724
725# invalid defined macro
726$notdef = eval { &ExtTest::EW };
727if (defined $notdef) {
728  print "not ok $test # \$notdef='$notdef'\n";
729} elsif ($@ !~ /^EW is not a valid ExtTest macro/) {
730  print "not ok $test # \$@='$@'\n";
731} else {
732  print "ok $test\n";
733}
734$test++;
735
736my %compass = (
737EOT
738
739while (my ($point, $bearing) = each %compass) {
740  $test_body .= "'$point' => $bearing, "
741}
742
743$test_body .= <<'EOT';
744
745);
746
747my $fail;
748while (my ($point, $bearing) = each %compass) {
749  my $val = eval $point;
750  if ($@) {
751    print "# $point: \$@='$@'\n";
752    $fail = 1;
753  } elsif (!defined $bearing) {
754    print "# $point: \$val=undef\n";
755    $fail = 1;
756  } elsif ($val != $bearing) {
757    print "# $point: \$val=$val, not $bearing\n";
758    $fail = 1;
759  }
760}
761if ($fail) {
762  print "not ok $test\n";
763} else {
764  print "ok $test\n";
765}
766$test++;
767
768EOT
769
770$test_body .= <<"EOT";
771my \$rfc1149 = RFC1149;
772if (\$rfc1149 ne "$parent_rfc1149") {
773  print "not ok \$test # '\$rfc1149' ne '$parent_rfc1149'\n";
774} else {
775  print "ok \$test\n";
776}
777\$test++;
778
779if (\$rfc1149 != 1149) {
780  printf "not ok \$test # %d != 1149\n", \$rfc1149;
781} else {
782  print "ok \$test\n";
783}
784\$test++;
785
786EOT
787
788$test_body .= <<'EOT';
789# test macro=>1
790my $open = OPEN;
791if ($open eq '/*') {
792  print "ok $test\n";
793} else {
794  print "not ok $test # \$open='$open'\n";
795}
796$test++;
797EOT
798$dummytest+=18;
799
800  end_tests("Simple tests", \@items, \@export_names, $header, $test_body,
801	    $args);
802}
803
804if ($do_utf_tests) {
805  # utf8 tests
806  start_tests();
807  my ($inf, $pound_bytes, $pound_utf8);
808
809  $inf = chr 0x221E;
810  # Check that we can distiguish the pathological case of a string, and the
811  # utf8 representation of that string.
812  $pound_utf8 = $pound . '1';
813  if ($better_than_56) {
814    $pound_bytes = $pound_utf8;
815    utf8::encode ($pound_bytes);
816  } else {
817    # Must have that "U*" to generate a zero length UTF string that forces
818    # top bit set chars (such as the pound sign) into UTF8, so that the
819    # unpack 'C*' then gets the byte form of the UTF8.
820    $pound_bytes =  pack 'C*', unpack 'C*', $pound_utf8 . pack "U*";
821  }
822
823  my @items = (@common_items,
824               {name=>$inf, type=>"PV", value=>'"Infinity"', macro=>1},
825               {name=>$pound_utf8, type=>"PV", value=>'"1 Pound"', macro=>1},
826               {name=>$pound_bytes, type=>"PV", value=>'"1 Pound (as bytes)"',
827                macro=>1},
828              );
829
830=pod
831
832The above set of names seems to produce a suitably bad set of compile
833problems on a Unicode naive version of ExtUtils::Constant (ie 0.11):
834
835nick@thinking-cap 15439-32-utf$ PERL_CORE=1 ./perl lib/ExtUtils/t/Constant.t
8361..33
837# perl=/stuff/perl5/15439-32-utf/perl
838# ext-30370 being created...
839Wide character in print at lib/ExtUtils/t/Constant.t line 140.
840ok 1
841ok 2
842# make = 'make'
843ExtTest.xs: In function `constant_1':
844ExtTest.xs:80: warning: multi-character character constant
845ExtTest.xs:80: warning: case value out of range
846ok 3
847
848=cut
849
850# Grr `
851
852  # Do this in 7 bit in case someone is testing with some settings that cause
853  # 8 bit files incapable of storing this character.
854  my @values
855    = map {"'" . join (",", unpack "U*", $_ . pack "U*") . "'"}
856      ($pound, $inf, $pound_bytes, $pound_utf8);
857  # Values is a list of strings, such as ('194,163,49', '163,49')
858
859  my $test_body .= "my \$test = $dummytest;\n";
860  $dummytest += 7 * 3; # 3 tests for each of the 7 things:
861
862  $test_body .= << 'EOT';
863
864use utf8;
865my $better_than_56 = $] > 5.007;
866
867my ($pound, $inf, $pound_bytes, $pound_utf8) = map {eval "pack 'U*', $_"}
868EOT
869
870  $test_body .= join ",", @values;
871
872  $test_body .= << 'EOT';
873;
874
875foreach (["perl", "rules", "rules"],
876	 ["/*", "OPEN", "OPEN"],
877	 ["*/", "CLOSE", "CLOSE"],
878	 [$pound, 'Sterling', []],
879         [$inf, 'Infinity', []],
880	 [$pound_utf8, '1 Pound', '1 Pound (as bytes)'],
881	 [$pound_bytes, '1 Pound (as bytes)', []],
882        ) {
883  # Flag an expected error with a reference for the expect string.
884  my ($string, $expect, $expect_bytes) = @$_;
885  (my $name = $string) =~ s/([^ !"#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])/sprintf '\x{%X}', ord $1/ges;
886  print "# \"$name\" => \'$expect\'\n";
887  # Try to force this to be bytes if possible.
888  if ($better_than_56) {
889    utf8::downgrade ($string, 1);
890  } else {
891    if ($string =~ tr/0-\377// == length $string) {
892      # No chars outside range 0-255
893      $string = pack 'C*', unpack 'U*', ($string . pack 'U*');
894    }
895  }
896EOT
897
898  $test_body .=  "my (\$error, \$got) = ${package}::constant (\$string);\n";
899
900  $test_body .= <<'EOT';
901  if ($error or $got ne $expect) {
902    print "not ok $test # error '$error', got '$got'\n";
903  } else {
904    print "ok $test\n";
905  }
906  $test++;
907  print "# Now upgrade '$name' to utf8\n";
908  if ($better_than_56) {
909    utf8::upgrade ($string);
910  } else {
911    $string = pack ('U*') . $string;
912  }
913EOT
914
915  $test_body .=  "my (\$error, \$got) = ${package}::constant (\$string);\n";
916
917  $test_body .= <<'EOT';
918  if ($error or $got ne $expect) {
919    print "not ok $test # error '$error', got '$got'\n";
920  } else {
921    print "ok $test\n";
922  }
923  $test++;
924  if (defined $expect_bytes) {
925    print "# And now with the utf8 byte sequence for name\n";
926    # Try the encoded bytes.
927    if ($better_than_56) {
928      utf8::encode ($string);
929    } else {
930      $string = pack 'C*', unpack 'C*', $string . pack "U*";
931    }
932EOT
933
934    $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n";
935
936    $test_body .= <<'EOT';
937    if (ref $expect_bytes) {
938      # Error expected.
939      if ($error) {
940        print "ok $test # error='$error' (as expected)\n";
941      } else {
942        print "not ok $test # expected error, got no error and '$got'\n";
943      }
944    } elsif ($got ne $expect_bytes) {
945      print "not ok $test # error '$error', expect '$expect_bytes', got '$got'\n";
946    } else {
947      print "ok $test\n";
948    }
949    $test++;
950  }
951}
952EOT
953
954  end_tests("utf8 tests", \@items, [], "#define perl \"rules\"\n", $test_body);
955}
956
957# XXX I think that I should merge this into the utf8 test above.
958sub explict_call_constant {
959  my ($string, $expect) = @_;
960  # This does assume simple strings suitable for ''
961  my $test_body = <<"EOT";
962{
963  my (\$error, \$got) = ${package}::constant ('$string');\n;
964EOT
965
966  if (defined $expect) {
967    # No error expected
968    $test_body .= <<"EOT";
969  if (\$error or \$got ne "$expect") {
970    print "not ok $dummytest # error '\$error', expect '$expect', got '\$got'\n";
971  } else {
972    print "ok $dummytest\n";
973    }
974  }
975EOT
976  } else {
977    # Error expected.
978    $test_body .= <<"EOT";
979  if (\$error) {
980    print "ok $dummytest # error='\$error' (as expected)\n";
981  } else {
982    print "not ok $dummytest # expected error, got no error and '\$got'\n";
983  }
984EOT
985  }
986  $dummytest++;
987  return $test_body . <<'EOT';
988}
989EOT
990}
991
992# Simple tests to verify bits of the switch generation system work.
993sub simple {
994  start_tests();
995  # Deliberately leave $name in @_, so that it is indexed from 1.
996  my ($name, @items) = @_;
997  my $test_header;
998  my $test_body = "my \$value;\n";
999  foreach my $counter (1 .. $#_) {
1000    my $thisname = $_[$counter];
1001    $test_header .= "#define $thisname $counter\n";
1002    $test_body .= <<"EOT";
1003\$value = $thisname;
1004if (\$value == $counter) {
1005  print "ok $dummytest\n";
1006} else {
1007  print "not ok $dummytest # $thisname gave \$value\n";
1008}
1009EOT
1010    ++$dummytest;
1011    # Yes, the last time round the loop appends a z to the string.
1012    for my $i (0 .. length $thisname) {
1013      my $copyname = $thisname;
1014      substr ($copyname, $i, 1) = 'z';
1015      $test_body .= explict_call_constant ($copyname,
1016                                           $copyname eq $thisname
1017                                             ? $thisname : undef);
1018    }
1019  }
1020  # Ho. This seems to be buggy in 5.005_03:
1021  # # Now remove $name from @_:
1022  # shift @_;
1023  end_tests($name, \@items, \@items, $test_header, $test_body);
1024}
1025
1026# Check that the memeq clauses work correctly when there isn't a switch
1027# statement to bump off a character
1028simple ("Singletons", "A", "AB", "ABC", "ABCD", "ABCDE");
1029# Check the three code.
1030simple ("Three start", qw(Bea kea Lea lea nea pea rea sea tea Wea yea Zea));
1031# There were 162 2 letter words in /usr/share/dict/words on FreeBSD 4.6, which
1032# I felt was rather too many. So I used words with 2 vowels.
1033simple ("Twos and three middle", qw(aa ae ai ea eu ie io oe era eta));
1034# Given the choice go for the end, else the earliest point
1035simple ("Three end and four symetry", qw(ean ear eat barb marm tart));
1036
1037
1038# Need this if the single test below is rolled into @tests :
1039# --$dummytest;
1040print "1..$dummytest\n";
1041
1042write_and_run_extension @$_ foreach @tests;
1043
1044# This was causing an assertion failure (a C<confess>ion)
1045# Any single byte > 128 should do it.
1046C_constant ($package, undef, undef, undef, undef, undef, chr 255);
1047print "ok $realtest\n"; $realtest++;
1048
1049print STDERR "# You were running with \$keep_files set to $keep_files\n"
1050  if $keep_files;
1051