Constant.t revision 7c478bd95313f5f23a4c958a745db2134aa03244
BEGIN {
chdir 't' if -d 't';
}
use Config;
print "1..0 # no usedl, skipping\n";
exit 0;
}
}
# use warnings;
use strict;
use Cwd;
my $do_utf_tests = $] > 5.006;
my $better_than_56 = $] > 5.007;
# For debugging set this to 1.
my $keep_files = 0;
$| = 1;
# Because were are going to be changing directory before running Makefile.PL
my $perl = $^X;
# 5.005 doesn't have new enough File::Spec to have rel2abs. But actually we
# only need it when $^X isn't absolute, which is going to be 5.8.0 or later
# (where ExtUtils::Constant is in the core, and tests against the uninstalled
# perl)
# ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to
# compare output to ensure that it is the same. We were probably run as ./perl
# whereas we will run the child with the full path in $perl. So make $^X for
# us the same as our child will see.
$^X = $perl;
print "# perl=$perl\n";
# Renamed by make clean
my $output = "output";
my $package = "ExtTest";
my $dir = "ext-$$";
my $subdir = 0;
# The real test counter.
my $realtest = 1;
print "# $dir being created...\n";
END {
} else {
# Can't get here.
}
}
sub check_for_bonus_files {
my $dir = shift;
my $fail;
$fail = 1;
}
} else {
}
$realtest++;
}
sub build_and_run {
if ($?) {
exit($?);
} else {
}
$realtest++;
} else {
}
$realtest++;
my @makeout;
if ($?) {
exit($?);
} else {
}
$realtest++;
} else {
if ($?) {
exit($?);
} else {
}
}
$realtest++;
local $/; # Slurp it - faster.
print <OUTPUT>;
} else {
# Harness will report missing test results at this point.
}
if ($?) {
} else {
}
$realtest++;
# -x is busted on Win32 < 5.6.1, so we emulate it.
my $regen;
my $saw_shebang;
$saw_shebang++ if /^#!.*/i ;
print REGENTMP $_ if $saw_shebang;
}
}
else {
}
if ($?) {
} else {
}
$realtest++;
} else {
# open FOO, ">expect"; print FOO $expect;
# open FOO, ">regen"; print FOO $regen; close FOO;
}
$realtest++;
if ($?) {
} else {
}
$realtest++;
# Need to make distclean to remove ../../lib/ExtTest.pm
if ($?) {
} else {
}
$realtest++;
}
}
}
sub Makefile_PL {
my $package = shift;
################ Makefile.PL
# We really need a Makefile.PL because make test for a no dynamic linking perl
# will run Makefile.PL again as part of the "make perl" target.
#!$perl -w
(\$] >= 5.005 ?
);
return $makefilePL;
}
sub MANIFEST {
################ MANIFEST
# We really need a MANIFEST because make distclean checks it.
return @files;
}
sub write_and_run_extension {
my ($name, $items, $export_names, $package, $header, $testfile, $num_tests)
= @_;
my $types = {};
my $expect = $constant_types . $C_constant .
my @files;
################ Header
################ XS
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
# XXX Here doc these:
print FH $constant_types;
print FH $XS_constant;
################ PM
use strict;
use Carp;
require Exporter;
require DynaLoader;
# Having this qw( in the here doc confuses cperl mode far too much to be
# helpful. And I'm using cperl mode to edit this, even if you're not :-)
# Print the names of all our autoloaded constants
# Print the AUTOLOAD subroutine ExtUtils::Constant generated for us
################ test.pl
# Standard test header (need an option to suppress this?)
use strict;
print "1..2\n";
print "ok 1\n";
select OUTPUT;
} else {
exit 1;
}
select STDOUT;
print "ok 2\n";
} else {
}
++$subdir;
}
# Tests are arrayrefs of the form
# $name, [items], [export_names], $package, $header, $testfile, $num_tests
my @tests;
my $before_tests = 4; # Number of "ok"s emitted to build extension
my $after_tests = 8; # Number of "ok"s emitted after make test run
my $dummytest = 1;
my $here;
sub start_tests {
$here = $dummytest;
}
sub end_tests {
$dummytest - $here];
}
my $pound;
} else { # ASCII platform
}
my @common_items = (
);
{
# Simple tests
my $parent_rfc1149 =
'A Standard for the Transmission of IP Datagrams on Avian Carriers';
# Test the code that generates 1 and 2 letter name comparisons.
my %compass = (
);
#define FIVE 5
#define OK6 "ok 6\\n"
#define OK7 1
#define FARTHING 0.25
#define NOT_ZERO 1
#define Yes 0
#define No 1
#define Undef 1
#define RFC1149 "$parent_rfc1149"
#undef NOTDEF
#define perl "rules"
}
# OK. It wasn't really designed to allow the creation of dual valued
# constants.
# It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
pre=>"SV *temp_sv = newSVpv(RFC1149, 0); "
. "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); "
. "SvIVX(temp_sv) = 1149;"},
);
# Automatically compile the list of all the macro names, and make them
# exported constants.
# Exporter::Heavy (currently) isn't able to export the last 3 of these:
push @items, @common_items;
# XXX there are hardwired still.
# What follows goes to the temporary file.
# IV
print "ok 5\n";
} else {
print "not ok 5 # \$five\n";
}
# PV
print OK6;
# PVN containing embedded \0s
$_ = OK7;
s/.*\0//s;
print;
# NV
print "ok 8\n";
} else {
}
# UV
print "ok 9\n";
} else {
}
# Value includes a "*/" in an attempt to bust out of a C comment.
# Also tests custom cpp #if clauses
print "ok 10\n";
} else {
}
# Default values if macro not defined.
print "ok 11\n";
} else {
}
# not defined macro
print "not ok 12 # \$@='$@'\n";
} else {
print "ok 12\n";
}
# not a macro
chomp $@;
print "not ok 13 # \$@='$@'\n";
} else {
print "ok 13\n";
}
# Truth
print "ok 14\n";
} else {
}
# Falsehood
print "ok 15\n";
} else {
}
# Undef
print "ok 16\n";
} else {
}
# invalid macro (chosen to look like a mix up between No and SW)
print "not ok 17 # \$@='$@'\n";
} else {
print "ok 17\n";
}
# invalid defined macro
print "not ok 18 # \$@='$@'\n";
} else {
print "ok 18\n";
}
my %compass = (
$test_body .= "'$point' => $bearing, "
}
);
my $fail;
if ($@) {
$fail = 1;
$fail = 1;
$fail = 1;
}
}
print "not ok 19\n";
} else {
print "ok 19\n";
}
} else {
print "ok 20\n";
}
} else {
print "ok 21\n";
}
# test macro=>1
print "ok 22\n";
} else {
}
$dummytest+=18;
}
# utf8 tests
# Check that we can distiguish the pathological case of a string, and the
# utf8 representation of that string.
} else {
# Must have that "U*" to generate a zero length UTF string that forces
# top bit set chars (such as the pound sign) into UTF8, so that the
# unpack 'C*' then gets the byte form of the UTF8.
}
my @items = (@common_items,
macro=>1},
);
=pod
1..33
# ext-30370 being created...
ok 1
ok 2
# make = 'make'
ExtTest.xs:80: warning: multi-character character constant
ExtTest.xs:80: warning: case value out of range
ok 3
=cut
# Grr `
# Do this in 7 bit in case someone is testing with some settings that cause
# 8 bit files incapable of storing this character.
my @values
= map {"'" . join (",", unpack "U*", $_ . pack "U*") . "'"}
($pound, $inf, $pound_bytes, $pound_utf8);
# Values is a list of strings, such as ('194,163,49', '163,49')
my $test_body .= "my \$test = $dummytest;\n";
$dummytest += 7 * 3; # 3 tests for each of the 7 things:
use utf8;
my $better_than_56 = $] > 5.007;
my ($pound, $inf, $pound_bytes, $pound_utf8) = map {eval "pack 'U*', $_"}
EOT
$test_body .= join ",", @values;
;
foreach (["perl", "rules", "rules"],
["/*", "OPEN", "OPEN"],
["*/", "CLOSE", "CLOSE"],
) {
# Flag an expected error with a reference for the expect string.
my ($string, $expect, $expect_bytes) = @$_;
(my $name = $string) =~ s/([^ -~])/sprintf '\x{%X}', ord $1/ges;
print "# \"$name\" => \'$expect\'\n";
# Try to force this to be bytes if possible.
if ($better_than_56) {
utf8::downgrade ($string, 1);
} else {
if ($string =~ tr/0-\377// == length $string) {
# No chars outside range 0-255
$string = pack 'C*', unpack 'U*', ($string . pack 'U*');
}
}
EOT
$test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n";
if ($error or $got ne $expect) {
} else {
print "ok $test\n";
}
$test++;
if ($better_than_56) {
utf8::upgrade ($string);
} else {
$string = pack ('U*') . $string;
}
EOT
$test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n";
if ($error or $got ne $expect) {
} else {
print "ok $test\n";
}
$test++;
if (defined $expect_bytes) {
print "# And now with the utf8 byte sequence for name\n";
# Try the encoded bytes.
if ($better_than_56) {
utf8::encode ($string);
} else {
$string = pack 'C*', unpack 'C*', $string . pack "U*";
}
EOT
$test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n";
if (ref $expect_bytes) {
# Error expected.
if ($error) {
} else {
}
} elsif ($got ne $expect_bytes) {
} else {
print "ok $test\n";
}
$test++;
}
}
EOT
end_tests("utf8 tests", \@items, [], "#define perl \"rules\"\n", $test_body);
}
# XXX I think that I should merge this into the utf8 test above.
sub explict_call_constant {
my ($string, $expect) = @_;
# This does assume simple strings suitable for ''
my $test_body = <<"EOT";
{
EOT
if (defined $expect) {
# No error expected
$test_body .= <<"EOT";
if (\$error or \$got ne "$expect") {
} else {
print "ok $dummytest\n";
}
}
EOT
} else {
# Error expected.
$test_body .= <<"EOT";
if (\$error) {
} else {
}
EOT
}
$dummytest++;
}
EOT
}
# Simple tests to verify bits of the switch generation system work.
sub simple {
start_tests();
# Deliberately leave $name in @_, so that it is indexed from 1.
my ($name, @items) = @_;
my $test_header;
my $test_body = "my \$value;\n";
foreach my $counter (1 .. $#_) {
my $thisname = $_[$counter];
$test_header .= "#define $thisname $counter\n";
$test_body .= <<"EOT";
\$value = $thisname;
if (\$value == $counter) {
print "ok $dummytest\n";
} else {
print "not ok $dummytest # $thisname gave \$value\n";
}
EOT
++$dummytest;
# Yes, the last time round the loop appends a z to the string.
for my $i (0 .. length $thisname) {
my $copyname = $thisname;
substr ($copyname, $i, 1) = 'z';
$test_body .= explict_call_constant ($copyname,
$copyname eq $thisname
? $thisname : undef);
}
}
# Ho. This seems to be buggy in 5.005_03:
# # Now remove $name from @_:
# shift @_;
end_tests($name, \@items, \@items, $test_header, $test_body);
}
# Check that the memeq clauses work correctly when there isn't a switch
# statement to bump off a character
# Check the three code.
# I felt was rather too many. So I used words with 2 vowels.
# Given the choice go for the end, else the earliest point
# Need this if the single test below is rolled into @tests :
# --$dummytest;
write_and_run_extension @$_ foreach @tests;
# This was causing an assertion failure (a C<confess>ion)
# Any single byte > 128 should do it.
print STDERR "# You were running with \$keep_files set to $keep_files\n"
if $keep_files;