diff options
| -rwxr-xr-x | configpm | 76 | ||||
| -rw-r--r-- | lib/Config.t | 15 |
2 files changed, 53 insertions, 38 deletions
@@ -210,6 +210,34 @@ while (<CONFIG_SH>) { } close CONFIG_SH; +# Calculation for the keys for byteorder +# This is somewhat grim, but I need to run fetch_string here. +our $Config_SH = join "\n", @v_fast, @v_others; + +my $t = fetch_string ({}, 'ivtype'); +my $s = fetch_string ({}, 'ivsize'); + +# byteorder does exist on its own but we overlay a virtual +# dynamically recomputed value. + +# However, ivtype and ivsize will not vary for sane fat binaries + +my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I'; + +my $byteorder_code; +if ($s == 4 || $s == 8) { + my $list = join ',', reverse(2..$s); + my $format = 'a'x$s; + $byteorder_code = <<"EOT"; +my \$i = 0; +foreach my \$c ($list) { \$i |= ord(\$c); \$i <<= 8 } +\$i |= ord(1); +my \$byteorder = join('', unpack('$format', pack('$f', \$i))); +EOT +} else { + $byteorder_code = "my \$byteorder = '?'x$s;\n"; +} + print CONFIG @non_v, "\n"; # copy config summary format from the myconfig.SH script @@ -223,7 +251,7 @@ close(MYCONFIG); # before expanding it, because may have been made readonly if a perl # interpreter has been cloned. -print CONFIG "\n!END!\n", <<'EOT'; +print CONFIG "\n!END!\n", $byteorder_code, <<'EOT'; my $summary_expanded; sub myconfig { @@ -233,12 +261,19 @@ sub myconfig { $summary_expanded; } -our $Config_SH : unique = <<'!END!'; +local *_ = \my $a; +$_ = <<'!END!'; EOT print CONFIG join("", @v_fast, sort @v_others); -print CONFIG "!END!\n", $fetch_string; +print CONFIG <<'EOT'; +!END! +s/(byteorder=)(['"]).*?\2/$1$2$byteorder$2/m; +our $Config_SH : unique = $_; +EOT + +print CONFIG $fetch_string; print CONFIG <<'ENDOFEND'; @@ -384,45 +419,14 @@ sub TIEHASH { ENDOFSET } - -# Calculation for the keys for byteorder -# This is somewhat grim, but I need to run fetch_string here. -our $Config_SH = join "\n", @v_fast, @v_others; - -my $t = fetch_string ({}, 'ivtype'); -my $s = fetch_string ({}, 'ivsize'); - -# byteorder does exist on its own but we overlay a virtual -# dynamically recomputed value. - -# However, ivtype and ivsize will not vary for sane fat binaries - -my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I'; - -my $byteorder_code; -if ($s == 4 || $s == 8) { - my $list = join ',', reverse(2..$s); - my $format = 'a'x$s; - $byteorder_code = <<"EOT"; -my \$i = 0; -foreach my \$c ($list) { \$i |= ord(\$c); \$i <<= 8 } -\$i |= ord(1); -my \$value = join('', unpack('$format', pack('$f', \$i))); -EOT -} else { - $byteorder_code = "\$value = '?'x$s;\n"; -} - my $fast_config = join '', map { " $_,\n" } - sort values (%v_fast), 'byteorder => $value' ; + sort values (%v_fast), 'byteorder => $byteorder' ; -print CONFIG sprintf <<'ENDOFTIE', $byteorder_code, $fast_config; +print CONFIG sprintf <<'ENDOFTIE', $fast_config; # avoid Config..Exporter..UNIVERSAL search for DESTROY then AUTOLOAD sub DESTROY { } -%s - tie %%Config, 'Config', { %s }; diff --git a/lib/Config.t b/lib/Config.t index 68979c1d50..38acde6da4 100644 --- a/lib/Config.t +++ b/lib/Config.t @@ -62,8 +62,10 @@ ok(exists $Config{ccflags_nolargefiles}, "has ccflags_nolargefiles"); } } -like(Config::myconfig(), qr/osname=\Q$Config{osname}\E/, "myconfig"); -like(Config::config_sh(), qr/osname='\Q$Config{osname}\E'/, "config_sh"); +like(Config::myconfig(), qr/osname=\Q$Config{osname}\E/, "myconfig"); +like(Config::config_sh(), qr/osname='\Q$Config{osname}\E'/, "config_sh"); +like(Config::config_sh(), qr/byteorder='[1-8]+'/, + "config_sh has a valid byteorder"); foreach my $line (Config::config_re('c.*')) { like($line, qr/^c.*?=.*$/, 'config_re' ); } @@ -156,3 +158,12 @@ ok( exists $Config{d_fork}, "still d_fork"); is($Config{sig_num_init} =~ tr/,/,/, $Config{sig_size}, "sig_num_init size"); is($Config{sig_name_init} =~ tr/,/,/, $Config{sig_size}, "sig_name_init size"); + +# Test the troublesome virtual stuff +foreach my $pain (qw(byteorder)) { + # No config var is named with anything that is a regexp metachar" + my @result = Config::config_re($pain); + is (scalar @result, 1, "single result for config_re('$pain')"); + like ($result[0], qr/^$pain=(['"])$Config{$pain}\1$/, # grr ' + "which is the expected result for $pain"); +} |