Commit | Line | Data |
a48f8c77 |
1 | #!./perl |
2 | |
41aba5b7 |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | require "./test.pl"; |
7 | } |
8 | |
8d871aab |
9 | plan 'no_plan'; |
41aba5b7 |
10 | |
11 | use_ok('Config'); |
12 | |
13 | # Some (safe?) bets. |
14 | |
484fdf61 |
15 | ok(keys %Config > 500, "Config has more than 500 entries"); |
41aba5b7 |
16 | |
2ddb7828 |
17 | my ($first) = Config::config_sh() =~ /^(\S+)=/m; |
18 | die "Can't find first entry in Config::config_sh()" unless defined $first; |
19 | print "# First entry is '$first'\n"; |
20 | |
21 | # It happens that the we know what the first key should be. This is somewhat |
22 | # cheating, but there was briefly a bug where the key got a bonus newline. |
23 | my ($first_each) = each %Config; |
24 | is($first_each, $first, "First key from each is correct"); |
25 | ok(exists($Config{$first_each}), "First key exists"); |
26 | ok(!exists($Config{"\n$first"}), |
27 | "Check that first key with prepended newline isn't falsely existing"); |
41aba5b7 |
28 | |
29 | is($Config{PERL_REVISION}, 5, "PERL_REVISION is 5"); |
30 | |
d10bb151 |
31 | # Check that old config variable names are aliased to their new ones. |
32 | my %grandfathers = ( PERL_VERSION => 'PATCHLEVEL', |
33 | PERL_SUBVERSION => 'SUBVERSION', |
34 | PERL_CONFIG_SH => 'CONFIG' |
35 | ); |
36 | while( my($new, $old) = each %grandfathers ) { |
37 | isnt($Config{$new}, undef, "$new is defined"); |
38 | is($Config{$new}, $Config{$old}, "$new is aliased to $old"); |
39 | } |
40 | |
41aba5b7 |
41 | ok( exists $Config{cc}, "has cc"); |
42 | |
43 | ok( exists $Config{ccflags}, "has ccflags"); |
44 | |
45 | ok(!exists $Config{python}, "has no python"); |
46 | |
47 | ok( exists $Config{d_fork}, "has d_fork"); |
48 | |
49 | ok(!exists $Config{d_bork}, "has no d_bork"); |
50 | |
9829f96e |
51 | like($Config{ivsize}, qr/^(4|8)$/, "ivsize is 4 or 8 (it is $Config{ivsize})"); |
7956ade2 |
52 | |
8d871aab |
53 | # byteorder is virtual, but it has rules. |
41aba5b7 |
54 | |
9829f96e |
55 | like($Config{byteorder}, qr/^(1234|4321|12345678|87654321)$/, |
56 | "byteorder is 1234 or 4321 or 12345678 or 87654321 " |
57 | . "(it is $Config{byteorder})"); |
41aba5b7 |
58 | |
9829f96e |
59 | is(length $Config{byteorder}, $Config{ivsize}, |
60 | "byteorder is as long as ivsize (which is $Config{ivsize})"); |
41aba5b7 |
61 | |
62 | # ccflags_nolargefiles is virtual, too. |
63 | |
64 | ok(exists $Config{ccflags_nolargefiles}, "has ccflags_nolargefiles"); |
65 | |
66 | # Utility functions. |
67 | |
a48f8c77 |
68 | { |
69 | # make sure we can export what we say we can export. |
70 | package Foo; |
71 | my @exports = qw(myconfig config_sh config_vars config_re); |
72 | Config->import(@exports); |
73 | foreach my $func (@exports) { |
74 | ::ok( __PACKAGE__->can($func), "$func exported" ); |
75 | } |
6664971e |
76 | } |
41aba5b7 |
77 | |
8468119f |
78 | like(Config::myconfig(), qr/osname=\Q$Config{osname}\E/, "myconfig"); |
79 | like(Config::config_sh(), qr/osname='\Q$Config{osname}\E'/, "config_sh"); |
80 | like(Config::config_sh(), qr/byteorder='[1-8]+'/, |
81 | "config_sh has a valid byteorder"); |
8d871aab |
82 | foreach my $line (Config::config_re('c.*')) { |
83 | like($line, qr/^c.*?=.*$/, 'config_re' ); |
84 | } |
a48f8c77 |
85 | |
41aba5b7 |
86 | my $out = tie *STDOUT, 'FakeOut'; |
87 | |
307dc113 |
88 | Config::config_vars('cc'); # non-regex test of essential cfg-var |
41aba5b7 |
89 | my $out1 = $$out; |
90 | $out->clear; |
91 | |
307dc113 |
92 | Config::config_vars('d_bork'); # non-regex, non-existent cfg-var |
41aba5b7 |
93 | my $out2 = $$out; |
94 | $out->clear; |
95 | |
307dc113 |
96 | Config::config_vars('PERL_API_.*'); # regex, tagged multi-line answer |
4a305f6a |
97 | my $out3 = $$out; |
98 | $out->clear; |
99 | |
307dc113 |
100 | Config::config_vars('PERL_API_.*:'); # regex, tagged single-line answer |
4a305f6a |
101 | my $out4 = $$out; |
102 | $out->clear; |
41aba5b7 |
103 | |
307dc113 |
104 | Config::config_vars(':PERL_API_.*:'); # regex, non-tagged single-line answer |
4a305f6a |
105 | my $out5 = $$out; |
106 | $out->clear; |
107 | |
307dc113 |
108 | Config::config_vars(':PERL_API_.*'); # regex, non-tagged multi-line answer |
0c6e7072 |
109 | my $out6 = $$out; |
110 | $out->clear; |
111 | |
307dc113 |
112 | Config::config_vars('PERL_API_REVISION.*:'); # regex, tagged |
113 | my $out7 = $$out; |
114 | $out->clear; |
115 | |
9829f96e |
116 | # regex, non-tagged multi-line answer |
117 | Config::config_vars(':PERL_API_REVISION.*'); |
307dc113 |
118 | my $out8 = $$out; |
119 | $out->clear; |
120 | |
121 | Config::config_vars('PERL_EXPENSIVE_.*:'); # non-matching regex |
122 | my $out9 = $$out; |
123 | $out->clear; |
124 | |
125 | Config::config_vars('?flags'); # bogus regex, no explicit warning ! |
126 | my $out10 = $$out; |
127 | $out->clear; |
128 | |
4a305f6a |
129 | untie *STDOUT; |
307dc113 |
130 | |
131 | like($out1, qr/^cc='\Q$Config{cc}\E';/, "found config_var cc"); |
132 | like($out2, qr/^d_bork='UNKNOWN';/, "config_var d_bork is UNKNOWN"); |
133 | |
134 | # test for leading, trailing colon effects |
135 | is(scalar split(/;\n/, $out3), 3, "3 lines found"); |
136 | is(scalar split(/;\n/, $out6), 3, "3 lines found"); |
137 | |
138 | is($out4 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out4"); |
139 | is($out5 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out5"); |
140 | |
141 | is(scalar split(/=/, $out3), 4, "found 'tag='"); |
142 | is(scalar split(/=/, $out4), 4, "found 'tag='"); |
143 | |
144 | my @api; |
145 | |
146 | my @rev = @Config{qw(PERL_API_REVISION PERL_API_VERSION PERL_API_SUBVERSION)}; |
147 | |
148 | print ("# test tagged responses, multi-line and single-line\n"); |
149 | foreach $api ($out3, $out4) { |
150 | @api = $api =~ /PERL_API_(\w+)=(.*?)(?:;\n|\s)/mg; |
151 | is($api[0], "REVISION", "REVISION tag"); |
152 | is($api[4], "VERSION", "VERSION tag"); |
153 | is($api[2], "SUBVERSION", "SUBVERSION tag"); |
154 | is($api[1], "'$rev[0]'", "REVISION is $rev[0]"); |
155 | is($api[5], "'$rev[1]'", "VERSION is $rev[1]"); |
156 | is($api[3], "'$rev[2]'", "SUBVERSION is $rev[2]"); |
157 | } |
158 | |
159 | print("# test non-tagged responses, multi-line and single-line\n"); |
160 | foreach $api ($out5, $out6) { |
161 | @api = split /(?: |;\n)/, $api; |
162 | is($api[0], "'$rev[0]'", "revision is $rev[0]"); |
163 | is($api[2], "'$rev[1]'", "version is $rev[1]"); |
164 | is($api[1], "'$rev[2]'", "subversion is $rev[2]"); |
165 | } |
166 | |
167 | # compare to each other, the outputs for trailing, leading colon |
168 | $out7 =~ s/ $//; |
169 | is("$out7;\n", "PERL_API_REVISION=$out8", "got expected diffs"); |
170 | |
171 | like($out9, qr/\bnot\s+found\b/, "$out9 - perl is FREE !"); |
172 | like($out10, qr/\bnot\s+found\b/, "config_vars with invalid regexp"); |
0c6e7072 |
173 | |
41aba5b7 |
174 | # Read-only. |
175 | |
7956ade2 |
176 | undef $@; |
41aba5b7 |
177 | eval { $Config{d_bork} = 'borkbork' }; |
178 | like($@, qr/Config is read-only/, "no STORE"); |
179 | |
7956ade2 |
180 | ok(!exists $Config{d_bork}, "still no d_bork"); |
181 | |
182 | undef $@; |
41aba5b7 |
183 | eval { delete $Config{d_fork} }; |
184 | like($@, qr/Config is read-only/, "no DELETE"); |
185 | |
7956ade2 |
186 | ok( exists $Config{d_fork}, "still d_fork"); |
187 | |
188 | undef $@; |
41aba5b7 |
189 | eval { %Config = () }; |
190 | like($@, qr/Config is read-only/, "no CLEAR"); |
191 | |
7956ade2 |
192 | ok( exists $Config{d_fork}, "still d_fork"); |
193 | |
059ca955 |
194 | { |
195 | package FakeOut; |
41aba5b7 |
196 | |
059ca955 |
197 | sub TIEHANDLE { |
198 | bless(\(my $text), $_[0]); |
199 | } |
41aba5b7 |
200 | |
059ca955 |
201 | sub clear { |
202 | ${ $_[0] } = ''; |
203 | } |
41aba5b7 |
204 | |
059ca955 |
205 | sub PRINT { |
206 | my $self = shift; |
207 | $$self .= join('', @_); |
208 | } |
41aba5b7 |
209 | } |
210 | |
059ca955 |
211 | # Signal-related variables |
212 | # (this is actually a regression test for Configure.) |
213 | |
b25be8c8 |
214 | is($Config{sig_num_init} =~ tr/,/,/, $Config{sig_size}, "sig_num_init size"); |
215 | is($Config{sig_name_init} =~ tr/,/,/, $Config{sig_size}, "sig_name_init size"); |
8468119f |
216 | |
217 | # Test the troublesome virtual stuff |
a6ea9771 |
218 | my @virtual = qw(byteorder ccflags_nolargefiles ldflags_nolargefiles |
219 | libs_nolargefiles libswanted_nolargefiles); |
a644ec48 |
220 | |
2ddb7828 |
221 | # Also test that the first entry in config.sh is found correctly. There was |
222 | # special casing code for this |
e9a5b206 |
223 | |
224 | foreach my $pain ($first, @virtual) { |
a644ec48 |
225 | # No config var is named with anything that is a regexp metachar |
e89403c1 |
226 | ok(exists $Config{$pain}, "\$config('$pain') exists"); |
227 | |
a644ec48 |
228 | my @result = $Config{$pain}; |
229 | is (scalar @result, 1, "single result for \$config('$pain')"); |
230 | |
06482b90 |
231 | @result = Config::config_re($pain); |
232 | is (scalar @result, 1, "single result for config_re('$pain')"); |
375b6f9c |
233 | like ($result[0], qr/^$pain=(['"])\Q$Config{$pain}\E\1$/, # grr ' |
06482b90 |
234 | "which is the expected result for $pain"); |
8468119f |
235 | } |
e9a5b206 |
236 | |