Document and test Config::config_re().

(with tweaks)
Message-ID: <20020904190607.GG8367@ool-18b93024.dyn.optonline.net>

p4raw-id: //depot/perl@18077

diff --git a/configpm b/configpm
index 3eaed48..7816c8d 100755 (executable)
--- a/configpm
+++ b/configpm
@@ -65,31 +65,36 @@ printf CONFIG <<'ENDOFBEG', ($myver) x 3;
 # made to this file will be lost the next time perl is built.
 
 package Config;
-use Exporter ();
 @EXPORT = qw(%%Config);
-@EXPORT_OK = qw(myconfig config_sh config_vars);
+@EXPORT_OK = qw(myconfig config_sh config_vars config_re);
+
+my %%Export_Cache = map {($_ => 1)} (@EXPORT, @EXPORT_OK);
 
 # Define our own import method to avoid pulling in the full Exporter:
 sub import {
-  my $pkg = shift;
-  @_ = @EXPORT unless @_;
+    my $pkg = shift;
+    @_ = @EXPORT unless @_;
 
-  my @func = grep {$_ ne '%%Config'} @_;
-  local $Exporter::ExportLevel = 1;
-  Exporter::import('Config', @func) if @func;
+    my @funcs = grep $_ ne '%%Config', @_;
+    my $export_Config = @funcs < @_ ? 1 : 0;
 
-  return if @func == @_;
+    my $callpkg = caller(0);
+    foreach my $func (@funcs) {
+       die sprintf qq{"%%s" is not exported by the %%s module\n},
+           $func, __PACKAGE__ unless $Export_Cache{$func};
+       *{$callpkg.'::'.$func} = \&{$func};
+    }
 
-  my $callpkg = caller(0);
-  *{"$callpkg\::Config"} = \%%Config;
+    *{"$callpkg\::Config"} = \%%Config if $export_Config;
+    return;
 }
 
 die "Perl lib version (%s) doesn't match executable version ($])"
     unless $^V;
 
 $^V eq %s
-  or die "Perl lib version (%s) doesn't match executable version (" .
-    (sprintf "v%vd",$^V) . ")";
+    or die "Perl lib version (%s) doesn't match executable version (" .
+       sprintf("v%%vd",$^V) . ")";
 
 ENDOFBEG
 
@@ -218,11 +223,11 @@ print CONFIG "\n!END!\n", <<'EOT';
 my $summary_expanded = 0;
 
 sub myconfig {
-       return $summary if $summary_expanded;
-       $summary =~ s{\$(\w+)}
-                    { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge;
-       $summary_expanded = 1;
-       $summary;
+    return $summary if $summary_expanded;
+    $summary =~ s{\$(\w+)}
+                { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge;
+    $summary_expanded = 1;
+    $summary;
 }
 
 our $Config_SH : unique = <<'!END!';
@@ -321,23 +326,26 @@ sub config_sh {
 
 sub config_re {
     my $re = shift;
-    my @matches = grep /^$re=/, split /^/, $Config_SH;
-    @matches ? (print @matches) : print "$re: not found\n";
+    return map { chomp; $_ } grep /^$re=/, split /^/, $config_sh;
 }
 
 sub config_vars {
-    foreach(@_){
-       config_re($_), next if /\W/;
-       my $v=(exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
-       $v='undef' unless defined $v;
-       print "$_='$v';\n";
+    foreach (@_) {
+       if (/\W/) {
+           my @matches = config_re($_);
+           print map "$_\n", @matches ? @matches : "$_: not found";
+       } else {
+           my $v = (exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
+           $v = 'undef' unless defined $v;
+           print "$_='$v';\n";
+       }
     }
 }
 
 ENDOFEND
 
 if ($^O eq 'os2') {
-  print CONFIG <<'ENDOFSET';
+    print CONFIG <<'ENDOFSET';
 my %preconfig;
 if ($OS2::is_aout) {
     my ($value, $v) = $Config_SH =~ m/^used_aout='(.*)'\s*$/m;
@@ -349,19 +357,19 @@ if ($OS2::is_aout) {
 $preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
 sub TIEHASH { bless {%preconfig} }
 ENDOFSET
-  # Extract the name of the DLL from the makefile to avoid duplication
-  my ($f) = grep -r, qw(GNUMakefile Makefile);
-  my $dll;
-  if (open my $fh, '<', $f) {
-    while (<$fh>) {
-      $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
+    # Extract the name of the DLL from the makefile to avoid duplication
+    my ($f) = grep -r, qw(GNUMakefile Makefile);
+    my $dll;
+    if (open my $fh, '<', $f) {
+       while (<$fh>) {
+           $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
+       }
     }
-  }
-  print CONFIG <<ENDOFSET if $dll;
+    print CONFIG <<ENDOFSET if $dll;
 \$preconfig{dll_name} = '$dll';
 ENDOFSET
 } else {
-  print CONFIG <<'ENDOFSET';
+    print CONFIG <<'ENDOFSET';
 sub TIEHASH {
     bless $_[1], $_[0];
 }
@@ -385,21 +393,20 @@ 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 $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";
+    $byteorder_code = "\$value = '?'x$s;\n";
 }
 
 my $fast_config = join '', map { "    $_,\n" }
-  values (%v_fast), 'byteorder => $value' ;
+    values (%v_fast), 'byteorder => $value' ;
 
 print CONFIG sprintf <<'ENDOFTIE', $byteorder_code, $fast_config;
 
@@ -429,12 +436,14 @@ Config - access Perl configuration information
        print "built by gcc\n";
     } 
 
-    use Config qw(myconfig config_sh config_vars);
+    use Config qw(myconfig config_sh config_vars config_re);
 
     print myconfig();
 
     print config_sh();
 
+    print config_re();
+
     config_vars(qw(osname archname));
 
 
@@ -462,6 +471,11 @@ See also C<-V> in L<perlrun/Switches>.
 Returns the entire perl configuration information in the form of the
 original config.sh shell variable assignment script.
 
+=item config_re($regex)
+
+Like config_sh() but returns, as a list, only the config entries who's
+names match the $regex.
+
 =item config_vars(@names)
 
 Prints to STDOUT the values of the named configuration variable. Each is

diff --git a/lib/Config.t b/lib/Config.t
index 4678769..f13b402 100644 (file)
--- a/lib/Config.t
+++ b/lib/Config.t
@@ -1,10 +1,12 @@
+#!./perl
+
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require "./test.pl";
 }
 
-plan tests => 29;
+plan tests => 34;
 
 use_ok('Config');
 
@@ -50,13 +52,21 @@ ok(exists $Config{ccflags_nolargefiles}, "has ccflags_nolargefiles");
 
 # Utility functions.
 
-like(Config::myconfig(),  qr/cc='$Config{cc}'/, "myconfig");
-
-SKIP: {
-       skip "cc is tied in $^O", 1 if $^O eq 'MacOS';
-       like(Config::config_sh(), qr/cc='$Config{cc}'/, "config_sh");
+{
+    # make sure we can export what we say we can export.
+    package Foo;
+    my @exports = qw(myconfig config_sh config_vars config_re);
+    Config->import(@exports);
+    foreach my $func (@exports) {
+       ::ok( __PACKAGE__->can($func), "$func exported" );
+    }
 }
 
+like(Config::myconfig(),       qr/osname=$Config{osname}/,   "myconfig");
+like(Config::config_sh(),      qr/osname='$Config{osname}'/, "config_sh");
+like(join("\n", Config::config_re('c.*')),
+                              qr/^c.*?=/,                   'config_re' );
+
 my $out = tie *STDOUT, 'FakeOut';
 
 Config::config_vars('cc');