From: Michael G. Schwern Date: Wed, 4 Sep 2002 12:06:08 +0000 (-0700) Subject: Document and test Config::config_re(). X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a48f8c779b973cde21f91eb6230f57994f5c9ad9;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 < $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. 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 --- 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');