t/porting/bincompat.t - test the code itself not just the output

Our checks on the define info we expose via Internals::V(), especially
the sorted part, did not really work properly as it only checked defines
that are actually exposed in our standard builds.  Many of the defines
that are exposed in this list are special cases that would not be
enabled in a normal build we test under CI, and indeed prior to this
patch it was possible for us to produce unsorted output if certain
defines were enabled.

This patch adds checks that reads the actual code.  It checks that the
define and the string are the same, and it checks that strings would be
output in sorted order assuming every define was enabled.

There are two historical exceptions where the string we show and the
define use internally are different, but we work around these two cases
with as special case hash.

1 files changed, 43 insertions, 4 deletions

diff --git a/t/porting/bincompat.t b/t/porting/bincompat.t
index 01b52b24d5..dd9ade20c0 100644
--- a/t/porting/bincompat.t
+++ b/t/porting/bincompat.t
@@ -1,19 +1,58 @@
 #!./perl -w
+BEGIN {
+    chdir ".." if -e "./test.pl";
+    push @INC, "lib";
+}
 use strict;
-require './test.pl';
+require './t/test.pl';
 skip_all("Sorting order differs under EBCDIC") if $::IS_EBCDIC || $::IS_EBCDIC;
 
 use Config;
 
-plan(2);
-
-# Defiantly a white box test...
+my %legacy_different = (
+    # define                       # string
+    'VMS_WE_ARE_CASE_SENSITIVE' => 'VMS_SYMBOL_CASE_AS_IS',
+    'WIN32_NO_REGISTRY'         => 'USE_NO_REGISTRY',
+);
 
 # As we need to call it direct, we'll take advantage of its result ordering:
 my @to_check = qw(bincompat_options non_bincompat_options);
+my @file = qw(perl.h perl.c);
+my @var = qw(PL_bincompat_options non_bincompat_options);
 my @V = map {s/^ //r} Internals::V();
 
 while (my ($index, $sub) = each @to_check) {
     my $got = join ' ', sort &{Config->can($sub)}();
     is($got, $V[$index], "C source code has $sub in sorted order");
+    open my $fh, "<", $file[$index]
+        or die "Failed to open '$file[$index]': $!";
+    my @strs;
+    my @define;
+    while (<$fh>) {
+        if (/$var[$index]\[\]\s*=/ .. /^\s*"";/) {
+            if (/ifdef\s+(\w+)/) {
+                my $name = $1;
+                # ignore PERL_HASH_ vars as they are handled differently
+                # from the rest.
+                $name=~/PERL_HASH_/ and next;
+                push @define, $name;
+            }
+            elsif (/" ([^"]+)"/) {
+                my $name = $1;
+                # ignore PERL_HASH_ vars as they are handled differently
+                # from the rest.
+                $name=~/PERL_HASH_/ and next;
+                push @strs, $name;
+            }
+        }
+    }
+    foreach my $j (0 .. $#strs) {
+        my $want = $legacy_different{$define[$j]} || $define[$j];
+        my $str = $strs[$j];
+        is($strs[$j],$want, "String and define $j are the same ($strs[$j]) for $var[$index] in $file[$index]");
+    }
+    my @sorted_strs = sort @strs;
+    is("@strs","@sorted_strs", "Strings are sorted for $var[$index] in $file[$index]");
 }
+
+done_testing();