Config.t 8.32 KB
Newer Older
1
#!./perl -w
2 3 4 5 6 7

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require "./test.pl";

8 9 10 11
    plan ('no_plan');

    use_ok('Config');
}
12

13
use strict;
14 15 16 17 18

# Some (safe?) bets.

ok(keys %Config > 500, "Config has more than 500 entries");

19 20 21 22 23 24 25 26 27 28 29
my ($first) = Config::config_sh() =~ /^(\S+)=/m;
die "Can't find first entry in Config::config_sh()" unless defined $first;
print "# First entry is '$first'\n";

# It happens that the we know what the first key should be. This is somewhat
# cheating, but there was briefly a bug where the key got a bonus newline.
my ($first_each) = each %Config;
is($first_each, $first, "First key from each is correct");
ok(exists($Config{$first_each}), "First key exists");
ok(!exists($Config{"\n$first"}),
   "Check that first key with prepended newline isn't falsely existing");
30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52

is($Config{PERL_REVISION}, 5, "PERL_REVISION is 5");

# Check that old config variable names are aliased to their new ones.
my %grandfathers = ( PERL_VERSION       => 'PATCHLEVEL',
                     PERL_SUBVERSION    => 'SUBVERSION',
                     PERL_CONFIG_SH     => 'CONFIG'
                   );
while( my($new, $old) = each %grandfathers ) {
    isnt($Config{$new}, undef,       "$new is defined");
    is($Config{$new}, $Config{$old}, "$new is aliased to $old");
}

ok( exists $Config{cc},      "has cc");

ok( exists $Config{ccflags}, "has ccflags");

ok(!exists $Config{python},  "has no python");

ok( exists $Config{d_fork},  "has d_fork");

ok(!exists $Config{d_bork},  "has no d_bork");

53
like($Config{ivsize}, qr/^(4|8)$/, "ivsize is 4 or 8 (it is $Config{ivsize})");
54

55
# byteorder is virtual, but it has rules.
56

57 58 59
like($Config{byteorder}, qr/^(1234|4321|12345678|87654321)$/,
     "byteorder is 1234 or 4321 or 12345678 or 87654321 "
     . "(it is $Config{byteorder})");
60

61 62
is(length $Config{byteorder}, $Config{ivsize},
   "byteorder is as long as ivsize (which is $Config{ivsize})");
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79

# ccflags_nolargefiles is virtual, too.

ok(exists $Config{ccflags_nolargefiles}, "has ccflags_nolargefiles");

# Utility functions.

{
    # 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" );
    }
}

80 81 82 83 84 85 86
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' );
}
87 88 89

my $out = tie *STDOUT, 'FakeOut';

90
Config::config_vars('cc');	# non-regex test of essential cfg-var
91 92 93
my $out1 = $$out;
$out->clear;

94
Config::config_vars('d_bork');	# non-regex, non-existent cfg-var
95 96 97
my $out2 = $$out;
$out->clear;

98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
Config::config_vars('PERL_API_.*');	# regex, tagged multi-line answer
my $out3 = $$out;
$out->clear;

Config::config_vars('PERL_API_.*:');	# regex, tagged single-line answer
my $out4 = $$out;
$out->clear;

Config::config_vars(':PERL_API_.*:');	# regex, non-tagged single-line answer
my $out5 = $$out;
$out->clear;

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;

118 119
# regex, non-tagged multi-line answer
Config::config_vars(':PERL_API_REVISION.*');
120 121 122 123 124 125 126 127 128 129 130
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;

131
undef $out;
132 133
untie *STDOUT;

134 135 136 137
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
138 139 140 141
# Split in scalar context it deprecated, and will warn.
my @tmp;
is(scalar (@tmp = split(/;\n/, $out3)), 3, "3 lines found");
is(scalar (@tmp = split(/;\n/, $out6)), 3, "3 lines found");
142 143 144 145

is($out4 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out4");
is($out5 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out5");

146 147
is(scalar (@tmp = split(/=/, $out3)), 4, "found 'tag='");
is(scalar (@tmp = split(/=/, $out4)), 4, "found 'tag='");
148 149 150 151 152 153

my @api;

my @rev = @Config{qw(PERL_API_REVISION PERL_API_VERSION PERL_API_SUBVERSION)};

print ("# test tagged responses, multi-line and single-line\n");
154
foreach my $api ($out3, $out4) {
155 156 157 158 159 160 161 162 163 164
    @api = $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]");
}

print("# test non-tagged responses, multi-line and single-line\n");
165
foreach my $api ($out5, $out6) {
166 167 168 169 170 171 172 173 174 175 176 177
    @api = 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]");
}

# 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");
178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220

# Read-only.

undef $@;
eval { $Config{d_bork} = 'borkbork' };
like($@, qr/Config is read-only/, "no STORE");

ok(!exists $Config{d_bork}, "still no d_bork");

undef $@;
eval { delete $Config{d_fork} };
like($@, qr/Config is read-only/, "no DELETE");

ok( exists $Config{d_fork}, "still d_fork");

undef $@;
eval { %Config = () };
like($@, qr/Config is read-only/, "no CLEAR");

ok( exists $Config{d_fork}, "still d_fork");

{
    package FakeOut;

    sub TIEHANDLE {
	bless(\(my $text), $_[0]);
    }

    sub clear {
	${ $_[0] } = '';
    }

    sub PRINT {
	my $self = shift;
	$$self .= join('', @_);
    }
}

# Signal-related variables
# (this is actually a regression test for Configure.)

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");
221 222

# Test the troublesome virtual stuff
223 224 225 226 227 228 229 230 231 232 233 234 235 236
my @virtual = qw(byteorder ccflags_nolargefiles ldflags_nolargefiles
		 libs_nolargefiles libswanted_nolargefiles);

# Also test that the first entry in config.sh is found correctly. There was
# special casing code for this

foreach my $pain ($first, @virtual) {
  # No config var is named with anything that is a regexp metachar
  ok(exists $Config{$pain}, "\$config('$pain') exists");

  my @result = $Config{$pain};
  is (scalar @result, 1, "single result for \$config('$pain')");

  @result = Config::config_re($pain);
237
  is (scalar @result, 1, "single result for config_re('$pain')");
238 239 240 241 242 243 244
  like ($result[0], qr/^$pain=(['"])\Q$Config{$pain}\E\1$/, # grr '
	"which is the expected result for $pain");
}

# Check that config entries appear correctly in @INC
# TestInit.pm has probably already messed with our @INC
# This little bit of evil is to avoid a @ in the program, in case it confuses
245 246
# shell 1 liners. We used to use a perl 1-ism, until that was deprecated, so
# now some octal in an eval.
247 248 249
my ($path, $ver, @orig_inc)
  = split /\n/,
    runperl (nolib=>1,
250
	     prog=>'print qq{$_\n} foreach $^X, $], eval qq{\100INC}');
251 252 253 254 255 256 257 258

die "This perl is $] at $^X; other perl is $ver (at $path) "
  . '- failed to find this perl' unless $] eq $ver;

my %orig_inc;
@orig_inc{@orig_inc} = ();

my $failed;
259
# This [used to be] the order that directories are pushed onto @INC in perl.c:
260
foreach my $lib (qw(applibexp archlibexp privlibexp sitearchexp sitelibexp
261
		     vendorarchexp vendorlibexp)) {
262 263 264
  my $dir = $Config{$lib};
  SKIP: {
    skip "lib $lib not in \@INC on Win32" if $^O eq 'MSWin32';
265
    skip "lib $lib not in \@INC on os390" if $^O eq 'os390';
266 267
    skip "lib $lib not defined" unless defined $dir;
    skip "lib $lib not set" unless length $dir;
268 269 270 271 272
    # May be in @INC in either Unix or VMS format on VMS.
    if ($^O eq 'VMS' && !exists($orig_inc{$dir})) {
        $dir = VMS::Filespec::unixify($dir);
        $dir =~ s|/$||;
    }
273 274 275 276 277
    # So we expect to find it in @INC

    ok (exists $orig_inc{$dir}, "Expect $lib '$dir' to be in \@INC")
      or $failed++;
  }
278
}
279
_diag ('@INC is:', @orig_inc) if $failed;