lib/Config.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require "./test.pl";
   7
   8     plan ('no_plan');
   9
  10     use_ok('Config');
  11 }
  12
  13 use strict;
  14
  15 # Some (safe?) bets.
  16
  17 cmp_ok(keys %Config, '>', 500, "Config has more than 500 entries");
  18
  19 my ($first) = Config::config_sh() =~ /^(\S+)=/m;
  20 die "Can't find first entry in Config::config_sh()" unless defined $first;
  21 note("First entry is '$first'");
  22
  23 # It happens that the we know what the first key should be. This is somewhat
  24 # cheating, but there was briefly a bug where the key got a bonus newline.
  25 my ($first_each) = each %Config;
  26 is($first_each, $first, "First key from each is correct");
  27 ok(exists($Config{$first_each}), "First key exists");
  28 ok(!exists($Config{"\n$first"}),
  29    "Check that first key with prepended newline isn't falsely existing");
  30
  31 is($Config{PERL_REVISION}, 5, "PERL_REVISION is 5");
  32
  33 # Check that old config variable names are aliased to their new ones.
  34 my %legacy = (
  35     PERL_VERSION       => 'PATCHLEVEL',
  36     PERL_SUBVERSION    => 'SUBVERSION',
  37     PERL_CONFIG_SH     => 'CONFIG'
  38 );
  39 while( my($new, $old) = each %legacy ) {
  40     isnt($Config{$new}, undef,       "$new is defined");
  41     is($Config{$new}, $Config{$old}, "$new is aliased to $old");
  42 }
  43
  44 ok( exists $Config{cc},      "has cc");
  45
  46 ok( exists $Config{ccflags}, "has ccflags");
  47
  48 ok(!exists $Config{python},  "has no python");
  49
  50 ok( exists $Config{d_fork},  "has d_fork");
  51
  52 ok(!exists $Config{d_bork},  "has no d_bork");
  53
  54 {
  55     # check taint_support and tain_disabled are set up as expected.
  56
  57     ok( exists $Config{taint_support}, "has taint_support");
  58
  59     ok( exists $Config{taint_disabled}, "has taint_disabled");
  60
  61     is( $Config{taint_support}, ($Config{taint_disabled} ? "" : "define"),
  62         "taint_support = !taint_disabled");
  63
  64     ok( ($Config{taint_support} eq "" or $Config{taint_support} eq "define"),
  65         "taint_support is a valid value");
  66
  67     ok( ( $Config{taint_disabled} eq "" or $Config{taint_disabled} eq "silent" or
  68         $Config{taint_disabled} eq "define"),
  69         "taint_disabled is a valid value");
  70
  71     my @opts = Config::non_bincompat_options();
  72     my @want_taint_disabled = ("", "define", "silent");
  73     my @want_taint_support = ("define", "", "");
  74     my ($silent_no_taint_support) = grep $_ eq "SILENT_NO_TAINT_SUPPORT", @opts;
  75     my ($no_taint_support) = grep $_ eq "NO_TAINT_SUPPORT", @opts;
  76     my $no_taint_support_count = 0 + grep /NO_TAINT_SUPPORT/, @opts;
  77     my $want_count = $silent_no_taint_support ? 2 : $no_taint_support ? 1 : 0;
  78
  79     is ($no_taint_support_count, $want_count,
  80         "non_bincompat_options info on taint support is as expected");
  81     is( $Config{taint_disabled}, $want_taint_disabled[$no_taint_support_count],
  82         "taint_disabled is aligned with non_bincompat_options() data");
  83     is( $Config{taint_support}, $want_taint_support[$no_taint_support_count],
  84         "taint_support is aligned with non_bincompat_options() data");
  85 }
  86
  87 like($Config{ivsize}, qr/^(4|8)$/, "ivsize is 4 or 8 (it is $Config{ivsize})");
  88
  89 # byteorder is virtual, but it has rules.
  90
  91 like($Config{byteorder}, qr/^(1234|4321|12345678|87654321)$/,
  92      "byteorder is 1234 or 4321 or 12345678 or 87654321 "
  93      . "(it is $Config{byteorder})");
  94
  95 is(length $Config{byteorder}, $Config{ivsize},
  96    "byteorder is as long as ivsize (which is $Config{ivsize})");
  97
  98 # ccflags_nolargefiles is virtual, too.
  99
 100 ok(exists $Config{ccflags_nolargefiles}, "has ccflags_nolargefiles");
 101
 102 # Utility functions.
 103
 104 {
 105     # make sure we can export what we say we can export.
 106     package Foo;
 107     my @exports = qw(myconfig config_sh config_vars config_re);
 108     Config->import(@exports);
 109     foreach my $func (@exports) {
 110         ::ok( __PACKAGE__->can($func), "$func exported" );
 111     }
 112 }
 113
 114 like(Config::myconfig(), qr/osname=\Q$Config{osname}\E/,   "myconfig");
 115 like(Config::config_sh(), qr/osname='\Q$Config{osname}\E'/, "config_sh");
 116 like(Config::config_sh(), qr/byteorder='[1-8]+'/,
 117      "config_sh has a valid byteorder");
 118 foreach my $line (Config::config_re('c.*')) {
 119   like($line,                  qr/^c.*?=.*$/,                   'config_re' );
 120 }
 121
 122 my $out = tie *STDOUT, 'FakeOut';
 123
 124 Config::config_vars('cc');      # non-regex test of essential cfg-var
 125 my $out1 = $$out;
 126 $out->clear;
 127
 128 Config::config_vars('d_bork');  # non-regex, non-existent cfg-var
 129 my $out2 = $$out;
 130 $out->clear;
 131
 132 Config::config_vars('PERL_API_.*');     # regex, tagged multi-line answer
 133 my $out3 = $$out;
 134 $out->clear;
 135
 136 Config::config_vars('PERL_API_.*:');    # regex, tagged single-line answer
 137 my $out4 = $$out;
 138 $out->clear;
 139
 140 Config::config_vars(':PERL_API_.*:');   # regex, non-tagged single-line answer
 141 my $out5 = $$out;
 142 $out->clear;
 143
 144 Config::config_vars(':PERL_API_.*');    # regex, non-tagged multi-line answer
 145 my $out6 = $$out;
 146 $out->clear;
 147
 148 Config::config_vars('PERL_API_REVISION.*:'); # regex, tagged
 149 my $out7 = $$out;
 150 $out->clear;
 151
 152 # regex, non-tagged multi-line answer
 153 Config::config_vars(':PERL_API_REVISION.*');
 154 my $out8 = $$out;
 155 $out->clear;
 156
 157 Config::config_vars('PERL_EXPENSIVE_.*:'); # non-matching regex
 158 my $out9 = $$out;
 159 $out->clear;
 160
 161 Config::config_vars('?flags');  # bogus regex, no explicit warning !
 162 my $out10 = $$out;
 163 $out->clear;
 164
 165 undef $out;
 166 untie *STDOUT;
 167
 168 like($out1, qr/^cc='\Q$Config{cc}\E';/, "found config_var cc");
 169 like($out2, qr/^d_bork='UNKNOWN';/, "config_var d_bork is UNKNOWN");
 170
 171 # test for leading, trailing colon effects
 172 # Split in scalar context it deprecated, and will warn.
 173 my @tmp;
 174 is(scalar (@tmp = split(/;\n/, $out3)), 3, "3 lines found");
 175 is(scalar (@tmp = split(/;\n/, $out6)), 3, "3 lines found");
 176
 177 is($out4 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out4");
 178 is($out5 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out5");
 179
 180 is(scalar (@tmp = split(/=/, $out3)), 4, "found 'tag='");
 181 is(scalar (@tmp = split(/=/, $out4)), 4, "found 'tag='");
 182
 183 my @api;
 184
 185 my @rev = @Config{qw(PERL_API_REVISION PERL_API_VERSION PERL_API_SUBVERSION)};
 186
 187 note("test tagged responses, multi-line and single-line");
 188 foreach my $api ($out3, $out4) {
 189     @api = $api =~ /PERL_API_(\w+)=(.*?)(?:;\n|\s)/mg;
 190     is($api[0], "REVISION", "REVISION tag");
 191     is($api[4], "VERSION",  "VERSION tag");
 192     is($api[2], "SUBVERSION", "SUBVERSION tag");
 193     is($api[1], "'$rev[0]'", "REVISION is $rev[0]");
 194     is($api[5], "'$rev[1]'", "VERSION is $rev[1]");
 195     is($api[3], "'$rev[2]'", "SUBVERSION is $rev[2]");
 196 }
 197
 198 note("test non-tagged responses, multi-line and single-line");
 199 foreach my $api ($out5, $out6) {
 200     @api = split /(?: |;\n)/, $api;
 201     is($api[0], "'$rev[0]'", "revision is $rev[0]");
 202     is($api[2], "'$rev[1]'", "version is $rev[1]");
 203     is($api[1], "'$rev[2]'", "subversion is $rev[2]");
 204 }
 205
 206 # compare to each other, the outputs for trailing, leading colon
 207 $out7 =~ s/ $//;
 208 is("$out7;\n", "PERL_API_REVISION=$out8", "got expected diffs");
 209
 210 like($out9, qr/\bnot\s+found\b/, "$out9 - perl is FREE !");
 211 like($out10, qr/\bnot\s+found\b/, "config_vars with invalid regexp");
 212
 213 # Read-only.
 214
 215 undef $@;
 216 eval { $Config{d_bork} = 'borkbork' };
 217 like($@, qr/Config is read-only/, "no STORE");
 218
 219 ok(!exists $Config{d_bork}, "still no d_bork");
 220
 221 undef $@;
 222 eval { delete $Config{d_fork} };
 223 like($@, qr/Config is read-only/, "no DELETE");
 224
 225 ok( exists $Config{d_fork}, "still d_fork");
 226
 227 undef $@;
 228 eval { %Config = () };
 229 like($@, qr/Config is read-only/, "no CLEAR");
 230
 231 ok( exists $Config{d_fork}, "still d_fork");
 232
 233 {
 234     package FakeOut;
 235
 236     sub TIEHANDLE {
 237         bless(\(my $text), $_[0]);
 238     }
 239
 240     sub clear {
 241         ${ $_[0] } = '';
 242     }
 243
 244     sub PRINT {
 245         my $self = shift;
 246         $$self .= join('', @_);
 247     }
 248 }
 249
 250 # Signal-related variables
 251 # (this is actually a regression test for Configure.)
 252
 253 is($Config{sig_num_init}  =~ tr/,/,/, $Config{sig_size}, "sig_num_init size");
 254 is($Config{sig_name_init} =~ tr/,/,/, $Config{sig_size}, "sig_name_init size");
 255
 256 # Test the troublesome virtual stuff
 257 my @virtual = qw(byteorder ccflags_nolargefiles ldflags_nolargefiles
 258                  libs_nolargefiles libswanted_nolargefiles);
 259
 260 # Also test that the first entry in config.sh is found correctly. There was
 261 # special casing code for this
 262
 263 foreach my $pain ($first, @virtual) {
 264   # No config var is named with anything that is a regexp metachar
 265   ok(exists $Config{$pain}, "\$config('$pain') exists");
 266
 267   my @result = $Config{$pain};
 268   is (scalar @result, 1, "single result for \$config('$pain')");
 269
 270   @result = Config::config_re($pain);
 271   is (scalar @result, 1, "single result for config_re('$pain')");
 272   like ($result[0], qr/^$pain=(['"])\Q$Config{$pain}\E\1$/, # grr '
 273         "which is the expected result for $pain");
 274 }
 275
 276 # Check that config entries appear correctly in @INC
 277 # TestInit.pm has probably already messed with our @INC
 278 # This little bit of evil is to avoid a @ in the program, in case it confuses
 279 # shell 1 liners. We used to use a perl 1-ism, until that was deprecated, so
 280 # now some octal in an eval.
 281 my ($path, $ver, @orig_inc)
 282   = split /\n/,
 283     runperl (nolib=>1,
 284              prog=>'print qq{$_\n} foreach $^X, $], eval qq{\100INC}');
 285
 286 die "This perl is $] at $^X; other perl is $ver (at $path) "
 287   . '- failed to find this perl' unless $] eq $ver;
 288
 289 my %orig_inc;
 290 @orig_inc{@orig_inc} = ();
 291
 292 my $failed;
 293 # This [used to be] the order that directories are pushed onto @INC in perl.c:
 294 foreach my $lib (qw(applibexp archlibexp privlibexp sitearchexp sitelibexp
 295                      vendorarchexp vendorlibexp)) {
 296   my $dir = $Config{$lib};
 297   SKIP: {
 298     skip "lib $lib not in \@INC on Win32" if $^O eq 'MSWin32';
 299     skip "lib $lib not in \@INC on os390" if $^O eq 'os390';
 300     skip "lib $lib not defined" unless defined $dir;
 301     skip "lib $lib not set" unless length $dir;
 302     # May be in @INC in either Unix or VMS format on VMS.
 303     if ($^O eq 'VMS' && !exists($orig_inc{$dir})) {
 304         $dir = VMS::Filespec::unixify($dir);
 305         $dir =~ s|/$||;
 306     }
 307     # So we expect to find it in @INC
 308
 309     ok (exists $orig_inc{$dir}, "Expect $lib '$dir' to be in \@INC")
 310       or $failed++;
 311   }
 312 }
 313 _diag ('@INC is:', @orig_inc) if $failed;