Change 23303 by nicholas@no-spam on 2004/09/10 05:25:22
Integrate:
[ 23091]
Check each line of config_re output.
[ 23147]
Config::config_re and config_sh would report the byteorder as 'ffff'
[ 23185]
Subject: [PATCH] additional -V:foo tests
From: Jim Cromie <jcromie@no-spam>
Date: Mon, 02 Aug 2004 09:15:23 -0600
Message-ID: <410E5A8B.9030307@no-spam>
Affected files ...
... //depot/maint-5.8/perl/configpm#14 integrate
... //depot/maint-5.8/perl/lib/Config.t#7 integrate
... //depot/maint-5.8/perl/pod/perlrun.pod#40 integrate
Differences ...
==== //depot/maint-5.8/perl/configpm#14 (xtext) ====
Index: perl/configpm
--- perl/configpm#13~22981~ Wed Jun 23 06:08:18 2004
+++ perl/configpm Thu Sep 9 22:25:22 2004
@@no-spam -210,6 +210,34 @@no-spam
}
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", @no-spam @no-spam
+
+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 @no-spam "\n";
# copy config summary format from the myconfig.SH script
@@no-spam -223,7 +251,7 @@no-spam
# 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 {
@@no-spam -233,12 +261,19 @@no-spam
$summary_expanded;
}
-our $Config_SH : unique = <<'!END!';
+local *_ = \my $a;
+$_ = <<'!END!';
EOT
print CONFIG join("", @no-spam sort @no-spam
-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';
@@no-spam -333,11 +368,15 @@no-spam
}
sub config_vars {
+ # implements -V:cfgvar option (see perlrun -V:)
foreach (@no-spam {
+ # find optional leading, trailing colons; and query-spec
my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/; # flags fore and aft,
- my $prfx = $notag ? '': "$qry="; # prefix for print
- my $lnend = $lncont ? ' ' : ";\n"; # ending for print
+ # map colon-flags to print decorations
+ my $prfx = $notag ? '': "$qry="; # tag-prefix for print
+ my $lnend = $lncont ? ' ' : ";\n"; # line ending for print
+ # all config-vars are by definition \w only, any \W means regex
if ($qry =~ /\W/) {
my @no-spam = config_re($qry);
print map "$_$lnend", @no-spam ? @no-spam : "$qry: not found" if !$notag;
@@no-spam -384,44 +423,13 @@no-spam
ENDOFSET
}
-
-# Calculation for the keys for byteorder
-# This is somewhat grim, but I need to run fetch_string here.
-our $Config_SH = join "\n", @no-spam @no-spam
-
-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
==== //depot/maint-5.8/perl/lib/Config.t#7 (text) ====
Index: perl/lib/Config.t
--- perl/lib/Config.t#6~22981~ Wed Jun 23 06:08:18 2004
+++ perl/lib/Config.t Thu Sep 9 22:25:22 2004
@@no-spam -6,7 +6,7 @@no-spam
require "./test.pl";
}
-plan tests => 47;
+plan 'no_plan';
use_ok('Config');
@@no-spam -40,7 +40,7 @@no-spam
like($Config{ivsize}, qr/^(4|8)$/, "ivsize is 4 or 8 (it is $Config{ivsize})");
-# byteorder is virtual, but it has rules.
+# byteorder is virtual, but it has rules.
like($Config{byteorder}, qr/^(1234|4321|12345678|87654321)$/, "byteorder is 1234 or 4321 or 12345678 or 87654321 (it is $Config{byteorder})");
@@no-spam -62,56 +62,100 @@no-spam
}
}
-like(Config::myconfig(), qr/osname=\Q$Config{osname}\E/, "myconfig");
-like(Config::config_sh(), qr/osname='\Q$Config{osname}\E'/, "config_sh");
-like(join("\n", Config::config_re('c.*')),
- qr/^c.*?=/, 'config_re' );
+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' );
+}
my $out = tie *STDOUT, 'FakeOut';
-Config::config_vars('cc');
+Config::config_vars('cc'); # non-regex test of essential cfg-var
my $out1 = $$out;
$out->clear;
-Config::config_vars('d_bork');
+Config::config_vars('d_bork'); # non-regex, non-existent cfg-var
my $out2 = $$out;
$out->clear;
-Config::config_vars('PERL_API_.*');
+Config::config_vars('PERL_API_.*'); # regex, tagged multi-line answer
my $out3 = $$out;
$out->clear;
-Config::config_vars(':PERL_API_.*:');
+Config::config_vars('PERL_API_.*:'); # regex, tagged single-line answer
my $out4 = $$out;
$out->clear;
-Config::config_vars(':PERL_API_REVISION:');
+Config::config_vars(':PERL_API_.*:'); # regex, non-tagged single-line answer
my $out5 = $$out;
$out->clear;
-Config::config_vars('?flags');
+Config::config_vars(':PERL_API_.*'); # regex, non-tagged multi-line answer
my $out6 = $$out;
$out->clear;
+Config::config_vars('PERL_API_REVISION.*:'); # regex, tagged
+my $out7 = $$out;
+$out->clear;
+
+Config::config_vars(':PERL_API_REVISION.*'); # regex, non-tagged multi-line answer
+my $out8 = $$out;
+$out->clear;
+
+Config::config_vars('PERL_EXPENSIVE_.*:'); # non-matching regex
+my $out9 = $$out;
+$out->clear;
+
+Config::config_vars('?flags'); # bogus regex, no explicit warning !
+my $out10 = $$out;
+$out->clear;
+
untie *STDOUT;
-like($out1, qr/^cc='\Q$Config{cc}\E';/, "config_vars cc");
-like($out2, qr/^d_bork='UNKNOWN';/, "config_vars d_bork is UNKNOWN");
-is(3, scalar split(/\n/, $out3), "3 PERL_API vars found");
-my @no-spam = $out3 =~ /^PERL_API_(\w+)=(.*);/mg;
-is("'5'", $api[1], "1st is 5");
-is("'8'", $api[5], "2nd is 9");
-is("'0'", $api[3], "3rd is 1");
-@no-spam = split(/ /, $out4);
-is(3, @no-spam "trailing colon puts 3 terms on same line");
-unlike($out4, qr/=/, "leading colon suppresses param names");
-is("'5'", $api[0], "revision is 5");
-is("'8'", $api[2], "version is 9");
-is("'0'", $api[1], "subversion is 1");
+like($out1, qr/^cc='\Q$Config{cc}\E';/, "found config_var cc");
+like($out2, qr/^d_bork='UNKNOWN';/, "config_var d_bork is UNKNOWN");
+
+# test for leading, trailing colon effects
+is(scalar split(/;\n/, $out3), 3, "3 lines found");
+is(scalar split(/;\n/, $out6), 3, "3 lines found");
+
+is($out4 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out4");
+is($out5 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out5");
+
+is(scalar split(/=/, $out3), 4, "found 'tag='");
+is(scalar split(/=/, $out4), 4, "found 'tag='");
+
+my @no-spam
+
+my @no-spam = @no-spam PERL_API_VERSION PERL_API_SUBVERSION)};
+
+print ("# test tagged responses, multi-line and single-line\n");
+foreach $api ($out3, $out4) {
+ @no-spam = $api =~ /PERL_API_(\w+)=(.*?)(?:;\n|\s)/mg;
+ is($api[0], "REVISION", "REVISION tag");
+ is($api[4], "VERSION", "VERSION tag");
+ is($api[2], "SUBVERSION", "SUBVERSION tag");
+ is($api[1], "'$rev[0]'", "REVISION is $rev[0]");
+ is($api[5], "'$rev[1]'", "VERSION is $rev[1]");
+ is($api[3], "'$rev[2]'", "SUBVERSION is $rev[2]");
+}
-is("'5' ", $out5, "leading and trailing colons return just the value");
+print("# test non-tagged responses, multi-line and single-line\n");
+foreach $api ($out5, $out6) {
+ @no-spam = split /(?: |;\n)/, $api;
+ is($api[0], "'$rev[0]'", "revision is $rev[0]");
+ is($api[2], "'$rev[1]'", "version is $rev[1]");
+ is($api[1], "'$rev[2]'", "subversion is $rev[2]");
+}
-like($out6, qr/\bnot\s+found\b/, "config_vars with invalid regexp");
+# compare to each other, the outputs for trailing, leading colon
+$out7 =~ s/ $//;
+is("$out7;\n", "PERL_API_REVISION=$out8", "got expected diffs");
+
+like($out9, qr/\bnot\s+found\b/, "$out9 - perl is FREE !");
+like($out10, qr/\bnot\s+found\b/, "config_vars with invalid regexp");
# Read-only.
@@no-spam -155,3 +199,12 @@no-spam
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 @no-spam = Config::config_re($pain);
+ is (scalar @no-spam 1, "single result for config_re('$pain')");
+ like ($result[0], qr/^$pain=(['"])$Config{$pain}\1$/, # grr '
+ "which is the expected result for $pain");
+}
==== //depot/maint-5.8/perl/pod/perlrun.pod#40 (text) ====
Index: perl/pod/perlrun.pod
--- perl/pod/perlrun.pod#39~23302~ Thu Sep 9 14:45:33 2004
+++ perl/pod/perlrun.pod Thu Sep 9 22:25:22 2004
@@no-spam -820,12 +820,14 @@no-spam
prints summary of the major perl configuration values and the current
values of @no-spam
-=item B<-V:>I<name>
+=item B<-V:>I<configvar>
Prints to STDOUT the value of the named configuration variable(s),
-with multiples when your query looks like a regex.
-For example,
+with multiples when your configvar argument looks like a regex (has
+non-letters). For example:
+ $ perl -V:libc
+ libc='/lib/libc-2.2.4.so';
$ perl -V:lib.
libs='-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc';
libc='/lib/libc-2.2.4.so';
@@no-spam -846,7 +848,7 @@no-spam
compression-vars: zcat='' zip='zip' are here !
A leading colon removes the 'name=' part of the response, this allows
-you to map to the name you need.
+you to map to the name you need. (mnemonic: empty label)
$ echo "goodvfork="`./perl -Ilib -V::usevfork`
goodvfork=false;
End of Patch.