1N/A chdir 't' if -d 't'; 1N/A print "1..0 # no usedl, skipping\n"; 1N/A# For debugging set this to 1. 1N/A# Because were are going to be changing directory before running Makefile.PL 1N/A# 5.005 doesn't have new enough File::Spec to have rel2abs. But actually we 1N/A# only need it when $^X isn't absolute, which is going to be 5.8.0 or later 1N/A# (where ExtUtils::Constant is in the core, and tests against the uninstalled 1N/A# ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to 1N/A# compare output to ensure that it is the same. We were probably run as ./perl 1N/A# whereas we will run the child with the full path in $perl. So make $^X for 1N/A# us the same as our child will see. 1N/A# Renamed by make clean 1N/A# The real test counter. 1N/A die "cwd at start was empty, but directory '$dir' was created" if $dir; 1N/A $entry =~ s/\.$// if $^O eq 'VMS'; # delete trailing dot that indicates no extension 1N/A print "ok $realtest # This is dynamic linking, so no need to make perl\n"; 1N/A local $/; # Slurp it - faster. 1N/A # Harness will report missing test results at this point. 1N/A # -x is busted on Win32 < 5.6.1, so we emulate it. 1N/A if( $^O eq 'MSWin32' && $] <= 5.006001 ) { 1N/A # open FOO, ">expect"; print FOO $expect; 1N/A # open FOO, ">regen"; print FOO $regen; close FOO; 1N/A # We really need a Makefile.PL because make test for a no dynamic linking perl 1N/A ################ MANIFEST 1N/A # We really need a MANIFEST because make distclean checks it. 1N/A ################ Header 1N/A # XXX Here doc these: 1N/A print FH "PROTOTYPES: ENABLE\n"; 1N/A # Having this qw( in the here doc confuses cperl mode far too much to be 1N/A # helpful. And I'm using cperl mode to edit this, even if you're not :-) 1N/A print FH "\@EXPORT_OK = qw(\n"; 1N/A # Print the names of all our autoloaded constants 1N/A # Print the AUTOLOAD subroutine ExtUtils::Constant generated for us 1N/A # Standard test header (need an option to suppress this?) 1N/A print "not ok 1 # Failed to open '$output': \$!\n"; 1N/A print "not ok 2 # Failed to close '$output': \$!\n"; 1N/A# Tests are arrayrefs of the form 1N/A# $name, [items], [export_names], $package, $header, $testfile, $num_tests 1N/Aif (ord('A') == 193) { # EBCDIC platform 1N/A} else { # ASCII platform 1N/A 'A Standard for the Transmission of IP Datagrams on Avian Carriers'; 1N/A # Test the code that generates 1 and 2 letter name comparisons. 1N/A N => 0, 'NE' => 45, E => 90, SE => 135, 1N/A S => 180, SW => 225, W => 270, NW => 315 1N/A#define OK6 "ok 6\\n" 1N/A#define FARTHING 0.25 1N/A#define RFC1149 "$parent_rfc1149" 1N/A value=>['"not ok 7\\n\\0ok 7\\n"', 15]}, 1N/A # OK. It wasn't really designed to allow the creation of dual valued 1N/A # It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE 1N/A pre=>"SV *temp_sv = newSVpv(RFC1149, 0); " 1N/A . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); " 1N/A . "SvIVX(temp_sv) = 1149;"}, 1N/A # Automatically compile the list of all the macro names, and make them 1N/A # exported constants. 1N/A # Exporter::Heavy (currently) isn't able to export the last 3 of these: 1N/A # XXX there are hardwired still. 1N/A# What follows goes to the temporary file. 1N/A print "not ok 5 # \$five\n"; 1N/A# PVN containing embedded \0s 1N/A# Value includes a "*/" in an attempt to bust out of a C comment. 1N/A# Also tests custom cpp #if clauses 1N/A# Default values if macro not defined. 1N/A print "not ok 11 # What do you get if you multiply six by nine? '$answer'\n"; 1N/A print "not ok 12 # \$@='$@'\n"; 1N/A print "not ok 13 # \$@='$@'\n"; 1N/A print "not ok 14 # $yes='\$yes'\n"; 1N/A# invalid macro (chosen to look like a mix up between No and SW) 1N/A print "not ok 17 # \$@='$@'\n"; 1N/A# invalid defined macro 1N/A print "not ok 18 # \$@='$@'\n"; 1N/A print "not ok 19\n"; 1N/A # Check that we can distiguish the pathological case of a string, and the 1N/A # utf8 representation of that string. 1N/A # Must have that "U*" to generate a zero length UTF string that forces 1N/A # top bit set chars (such as the pound sign) into UTF8, so that the 1N/A # unpack 'C*' then gets the byte form of the UTF8. 1N/A# ext-30370 being created... 1N/A # Do this in 7 bit in case someone is testing with some settings that cause 1N/A # 8 bit files incapable of storing this character. 1N/A = map {"'" . join (",", unpack "U*", $_ . pack "U*") . "'"} 1N/A ($pound, $inf, $pound_bytes, $pound_utf8); 1N/A # Values is a list of strings, such as ('194,163,49', '163,49') 1N/A my $test_body .= "my \$test = $dummytest;\n"; 1N/A $dummytest += 7 * 3; # 3 tests for each of the 7 things: 1N/Amy $better_than_56 = $] > 5.007; 1N/Amy ($pound, $inf, $pound_bytes, $pound_utf8) = map {eval "pack 'U*', $_"} 1N/A $test_body .= join ",", @values; 1N/Aforeach (["perl", "rules", "rules"], 1N/A ["/*", "OPEN", "OPEN"], 1N/A ["*/", "CLOSE", "CLOSE"], 1N/A # Flag an expected error with a reference for the expect string. 1N/A my ($string, $expect, $expect_bytes) = @$_; 1N/A (my $name = $string) =~ s/([^ -~])/sprintf '\x{%X}', ord $1/ges; 1N/A print "# \"$name\" => \'$expect\'\n"; 1N/A # Try to force this to be bytes if possible. 1N/A if ($better_than_56) { 1N/A utf8::downgrade ($string, 1); 1N/A if ($string =~ tr/0-\377// == length $string) { 1N/A # No chars outside range 0-255 1N/A $string = pack 'C*', unpack 'U*', ($string . pack 'U*'); 1N/A $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n"; 1N/A if ($error or $got ne $expect) { 1N/A print "# Now upgrade '$name' to utf8\n"; 1N/A if ($better_than_56) { 1N/A utf8::upgrade ($string); 1N/A $string = pack ('U*') . $string; 1N/A $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n"; 1N/A if ($error or $got ne $expect) { 1N/A if (defined $expect_bytes) { 1N/A print "# And now with the utf8 byte sequence for name\n"; 1N/A # Try the encoded bytes. 1N/A if ($better_than_56) { 1N/A utf8::encode ($string); 1N/A $string = pack 'C*', unpack 'C*', $string . pack "U*"; 1N/A $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n"; 1N/A if (ref $expect_bytes) { 1N/A print "ok $test # error='$error' (as expected)\n"; 1N/A print "not ok $test # expected error, got no error and '$got'\n"; 1N/A } elsif ($got ne $expect_bytes) { 1N/A end_tests("utf8 tests", \@items, [], "#define perl \"rules\"\n", $test_body); 1N/A# XXX I think that I should merge this into the utf8 test above. 1N/Asub explict_call_constant { 1N/A my ($string, $expect) = @_; 1N/A # This does assume simple strings suitable for '' 1N/A my $test_body = <<"EOT"; 1N/A my (\$error, \$got) = ${package}::constant ('$string');\n; 1N/A if (defined $expect) { 1N/A $test_body .= <<"EOT"; 1N/A if (\$error or \$got ne "$expect") { 1N/A print "ok $dummytest\n"; 1N/A $test_body .= <<"EOT"; 1N/A print "ok $dummytest # error='\$error' (as expected)\n"; 1N/A print "not ok $dummytest # expected error, got no error and '\$got'\n"; 1N/A# Simple tests to verify bits of the switch generation system work. 1N/A # Deliberately leave $name in @_, so that it is indexed from 1. 1N/A my ($name, @items) = @_; 1N/A my $test_body = "my \$value;\n"; 1N/A foreach my $counter (1 .. $#_) { 1N/A my $thisname = $_[$counter]; 1N/A $test_header .= "#define $thisname $counter\n"; 1N/A $test_body .= <<"EOT"; 1N/Aif (\$value == $counter) { 1N/A print "ok $dummytest\n"; 1N/A print "not ok $dummytest # $thisname gave \$value\n"; 1N/A # Yes, the last time round the loop appends a z to the string. 1N/A for my $i (0 .. length $thisname) { 1N/A my $copyname = $thisname; 1N/A substr ($copyname, $i, 1) = 'z'; 1N/A $test_body .= explict_call_constant ($copyname, 1N/A $copyname eq $thisname 1N/A ? $thisname : undef); 1N/A # Ho. This seems to be buggy in 5.005_03: 1N/A # # Now remove $name from @_: 1N/A end_tests($name, \@items, \@items, $test_header, $test_body); 1N/A# Check that the memeq clauses work correctly when there isn't a switch 1N/A# statement to bump off a character 1N/Asimple ("Singletons", "A", "AB", "ABC", "ABCD", "ABCDE"); 1N/A# Check the three code. 1N/A# I felt was rather too many. So I used words with 2 vowels. 1N/A# Given the choice go for the end, else the earliest point 1N/A# Need this if the single test below is rolled into @tests : 1N/A# This was causing an assertion failure (a C<confess>ion) 1N/A# Any single byte > 128 should do it.