This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Back out #3735. Needs more work.
[perl5.git] / configpm
1 #!./miniperl -w
2
3 my $config_pm = $ARGV[0] || 'lib/Config.pm';
4 my $glossary = $ARGV[1] || 'Porting/Glossary';
5 @ARGV = "./config.sh";
6
7 # list names to put first (and hence lookup fastest)
8 @fast = qw(archname osname osvers prefix libs libpth
9         dynamic_ext static_ext extensions dlsrc so
10         sig_name sig_num cc ccflags cppflags
11         privlibexp archlibexp installprivlib installarchlib
12         sharpbang startsh shsharp
13 );
14
15 # names of things which may need to have slashes changed to double-colons
16 @extensions = qw(dynamic_ext static_ext extensions known_extensions);
17
18
19 open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n";
20 $myver = $];
21
22 print CONFIG <<"ENDOFBEG";
23 package Config;
24 use Exporter ();
25 \@ISA = (Exporter);
26 \@EXPORT = qw(%Config);
27 \@EXPORT_OK = qw(myconfig config_sh config_vars);
28
29 \$] == $myver
30   or die "Perl lib version ($myver) doesn't match executable version (\$])";
31
32 # This file was created by configpm when Perl was built. Any changes
33 # made to this file will be lost the next time perl is built.
34
35 ENDOFBEG
36
37
38 @fast{@fast} = @fast;
39 @extensions{@extensions} = @extensions;
40 @non_v=();
41 @v_fast=();
42 @v_others=();
43 $in_v = 0;
44
45 while (<>) {
46     next if m:^#!/bin/sh:;
47     # Catch CONFIGDOTSH=true and PERL_VERSION=n line from Configure.
48     s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/;
49     my ($k,$v) = ($1,$2);
50     # grandfather PATCHLEVEL and SUBVERSION and CONFIG
51     if ($k) {
52         if ($k eq 'PERL_VERSION') {
53             push @v_others, "PATCHLEVEL='$v'\n";
54         }
55         elsif ($k eq 'PERL_SUBVERSION') {
56             push @v_others, "SUBVERSION='$v'\n";
57         }
58         elsif ($k eq 'CONFIGDOTSH') {
59             push @v_others, "CONFIG='$v'\n";
60         }
61     }
62     # We can delimit things in config.sh with either ' or ". 
63     unless ($in_v or m/^(\w+)=(['"])(.*\n)/){
64         push(@non_v, "#$_"); # not a name='value' line
65         next;
66     }
67     $quote = $2;
68     if ($in_v) { $val .= $_;             }
69     else       { ($name,$val) = ($1,$3); }
70     $in_v = $val !~ /$quote\n/;
71     next if $in_v;
72     if ($extensions{$name}) { s,/,::,g }
73     if (!$fast{$name}){ push(@v_others, "$name=$quote$val"); next; }
74     push(@v_fast,"$name=$quote$val");
75 }
76
77 foreach(@non_v){ print CONFIG $_ }
78
79 print CONFIG "\n",
80     "my \$config_sh = <<'!END!';\n",
81     join("", @v_fast, sort @v_others),
82     "!END!\n\n";
83
84 # copy config summary format from the myconfig.SH script
85
86 print CONFIG "my \$summary = <<'!END!';\n";
87
88 open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
89 1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
90 do { print CONFIG $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
91 close(MYCONFIG);
92
93 print CONFIG "\n!END!\n", <<'EOT';
94 my $summary_expanded = 0;
95
96 sub myconfig {
97         return $summary if $summary_expanded;
98         $summary =~ s{\$(\w+)}
99                      { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge;
100         $summary_expanded = 1;
101         $summary;
102 }
103 EOT
104
105 # ----
106
107 print CONFIG <<'ENDOFEND';
108
109 sub FETCH { 
110     # check for cached value (which may be undef so we use exists not defined)
111     return $_[0]->{$_[1]} if (exists $_[0]->{$_[1]});
112
113     # Search for it in the big string 
114     my($value, $start, $marker, $quote_type);
115     $marker = "$_[1]=";
116     $quote_type = "'";
117     # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m);
118     # Check for the common case, ' delimeted
119     $start = index($config_sh, "\n$marker$quote_type");
120     # If that failed, check for " delimited
121     if ($start == -1) {
122       $quote_type = '"';
123       $start = index($config_sh, "\n$marker$quote_type");
124     }
125     return undef if ( ($start == -1) &&  # in case it's first 
126         (substr($config_sh, 0, length($marker)) ne $marker) );
127     if ($start == -1) { 
128       # It's the very first thing we found. Skip $start forward
129       # and figure out the quote mark after the =.
130       $start = length($marker) + 1;
131       $quote_type = substr($config_sh, $start - 1, 1);
132     } 
133     else { 
134       $start += length($marker) + 2;
135     }
136     $value = substr($config_sh, $start, 
137         index($config_sh, "$quote_type\n", $start) - $start);
138  
139     # If we had a double-quote, we'd better eval it so escape
140     # sequences and such can be interpolated. Since the incoming
141     # value is supposed to follow shell rules and not perl rules,
142     # we escape any perl variable markers
143     if ($quote_type eq '"') {
144       $value =~ s/\$/\\\$/g;
145       $value =~ s/\@/\\\@/g;
146       eval "\$value = \"$value\"";
147     }
148     #$value = sprintf($value) if $quote_type eq '"';
149     $value = undef if $value eq 'undef'; # So we can say "if $Config{'foo'}".
150     $_[0]->{$_[1]} = $value; # cache it
151     return $value;
152 }
153  
154 my $prevpos = 0;
155
156 sub FIRSTKEY {
157     $prevpos = 0;
158     # my($key) = $config_sh =~ m/^(.*?)=/;
159     substr($config_sh, 0, index($config_sh, '=') );
160     # $key;
161 }
162
163 sub NEXTKEY {
164     # Find out how the current key's quoted so we can skip to its end.
165     my $quote = substr($config_sh, index($config_sh, "=", $prevpos)+1, 1);
166     my $pos = index($config_sh, qq($quote\n), $prevpos) + 2;
167     my $len = index($config_sh, "=", $pos) - $pos;
168     $prevpos = $pos;
169     $len > 0 ? substr($config_sh, $pos, $len) : undef;
170 }
171
172 sub EXISTS { 
173     # exists($_[0]->{$_[1]})  or  $config_sh =~ m/^$_[1]=/m;
174     exists($_[0]->{$_[1]}) or
175     index($config_sh, "\n$_[1]='") != -1 or
176     substr($config_sh, 0, length($_[1])+2) eq "$_[1]='" or
177     index($config_sh, "\n$_[1]=\"") != -1 or
178     substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\"";
179 }
180
181 sub STORE  { die "\%Config::Config is read-only\n" }
182 sub DELETE { &STORE }
183 sub CLEAR  { &STORE }
184
185
186 sub config_sh {
187     $config_sh
188 }
189
190 sub config_re {
191     my $re = shift;
192     my @matches = ($config_sh =~ /^$re=.*\n/mg);
193     @matches ? (print @matches) : print "$re: not found\n";
194 }
195
196 sub config_vars {
197     foreach(@_){
198         config_re($_), next if /\W/;
199         my $v=(exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
200         $v='undef' unless defined $v;
201         print "$_='$v';\n";
202     }
203 }
204
205 ENDOFEND
206
207 if ($^O eq 'os2') {
208   print CONFIG <<'ENDOFSET';
209 my %preconfig;
210 if ($OS2::is_aout) {
211     my ($value, $v) = $config_sh =~ m/^used_aout='(.*)'\s*$/m;
212     for (split ' ', $value) {
213         ($v) = $config_sh =~ m/^aout_$_='(.*)'\s*$/m;
214         $preconfig{$_} = $v eq 'undef' ? undef : $v;
215     }
216 }
217 sub TIEHASH { bless {%preconfig} }
218 ENDOFSET
219 } else {
220   print CONFIG <<'ENDOFSET';
221 sub TIEHASH { bless {} }
222 ENDOFSET
223 }
224
225 print CONFIG <<'ENDOFTAIL';
226
227 # avoid Config..Exporter..UNIVERSAL search for DESTROY then AUTOLOAD
228 sub DESTROY { }
229
230 tie %Config, 'Config';
231
232 1;
233 __END__
234
235 =head1 NAME
236
237 Config - access Perl configuration information
238
239 =head1 SYNOPSIS
240
241     use Config;
242     if ($Config{'cc'} =~ /gcc/) {
243         print "built by gcc\n";
244     } 
245
246     use Config qw(myconfig config_sh config_vars);
247
248     print myconfig();
249
250     print config_sh();
251
252     config_vars(qw(osname archname));
253
254
255 =head1 DESCRIPTION
256
257 The Config module contains all the information that was available to
258 the C<Configure> program at Perl build time (over 900 values).
259
260 Shell variables from the F<config.sh> file (written by Configure) are
261 stored in the readonly-variable C<%Config>, indexed by their names.
262
263 Values stored in config.sh as 'undef' are returned as undefined
264 values.  The perl C<exists> function can be used to check if a
265 named variable exists.
266
267 =over 4
268
269 =item myconfig()
270
271 Returns a textual summary of the major perl configuration values.
272 See also C<-V> in L<perlrun/Switches>.
273
274 =item config_sh()
275
276 Returns the entire perl configuration information in the form of the
277 original config.sh shell variable assignment script.
278
279 =item config_vars(@names)
280
281 Prints to STDOUT the values of the named configuration variable. Each is
282 printed on a separate line in the form:
283
284   name='value';
285
286 Names which are unknown are output as C<name='UNKNOWN';>.
287 See also C<-V:name> in L<perlrun/Switches>.
288
289 =back
290
291 =head1 EXAMPLE
292
293 Here's a more sophisticated example of using %Config:
294
295     use Config;
296     use strict;
297
298     my %sig_num;
299     my @sig_name;
300     unless($Config{sig_name} && $Config{sig_num}) {
301         die "No sigs?";
302     } else {
303         my @names = split ' ', $Config{sig_name};
304         @sig_num{@names} = split ' ', $Config{sig_num};
305         foreach (@names) {
306             $sig_name[$sig_num{$_}] ||= $_;
307         }   
308     }
309
310     print "signal #17 = $sig_name[17]\n";
311     if ($sig_num{ALRM}) { 
312         print "SIGALRM is $sig_num{ALRM}\n";
313     }   
314
315 =head1 WARNING
316
317 Because this information is not stored within the perl executable
318 itself it is possible (but unlikely) that the information does not
319 relate to the actual perl binary which is being used to access it.
320
321 The Config module is installed into the architecture and version
322 specific library directory ($Config{installarchlib}) and it checks the
323 perl version number when loaded.
324
325 The values stored in config.sh may be either single-quoted or
326 double-quoted. Double-quoted strings are handy for those cases where you
327 need to include escape sequences in the strings. To avoid runtime variable
328 interpolation, any C<$> and C<@> characters are replaced by C<\$> and
329 C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
330 or C<\@> in double-quoted strings unless you're willing to deal with the
331 consequences. (The slashes will end up escaped and the C<$> or C<@> will
332 trigger variable interpolation)
333
334 =head1 GLOSSARY
335
336 Most C<Config> variables are determined by the C<Configure> script
337 on platforms supported by it (which is most UNIX platforms).  Some
338 platforms have custom-made C<Config> variables, and may thus not have
339 some of the variables described below, or may have extraneous variables
340 specific to that particular port.  See the port specific documentation
341 in such cases.
342
343 ENDOFTAIL
344
345 open(GLOS, "<$glossary") or die "Can't open $glossary: $!";
346 %seen = ();
347 $text = 0;
348 $/ = '';
349
350 sub process {
351   s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m;
352   my $c = substr $1, 0, 1;
353   unless ($seen{$c}++) {
354     print CONFIG <<EOF if $text;
355 =back
356
357 EOF
358     print CONFIG <<EOF;
359 =head2 $c
360
361 =over
362
363 EOF
364     $text = 1;
365   }
366   s/n't/n\00t/g;                # leave can't, won't etc untouched
367   s/^\t\s+(.*)/\n\t$1\n/gm;     # Indented lines ===> paragraphs
368   s/^(?<!\n\n)\t(.*)/$1/gm;     # Not indented lines ===> text
369   s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
370   s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
371   s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
372   s{
373      (?<! [\w./<\'\"] )         # Only standalone file names
374      (?! e \. g \. )            # Not e.g.
375      (?! \. \. \. )             # Not ...
376      (?! \d )                   # Not 5.004
377      ( [\w./]* [./] [\w./]* )   # Require . or / inside
378      (?<! \. (?= \s ) )         # Do not include trailing dot
379      (?! [\w/] )                # Include all of it
380    }
381    (F<$1>)xg;                   # /usr/local
382   s/((?<=\s)~\w*)/F<$1>/g;      # ~name
383   s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g;    # UNISTD
384   s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
385   s/n[\0]t/n't/g;               # undo can't, won't damage
386 }
387
388 <GLOS>;                         # Skip the preamble
389 while (<GLOS>) {
390   process;
391   print CONFIG;
392 }
393
394 print CONFIG <<'ENDOFTAIL';
395
396 =back
397
398 =head1 NOTE
399
400 This module contains a good example of how to use tie to implement a
401 cache and an example of how to make a tied variable readonly to those
402 outside of it.
403
404 =cut
405
406 ENDOFTAIL
407
408 close(CONFIG);
409 close(GLOS);
410
411 # Now do some simple tests on the Config.pm file we have created
412 unshift(@INC,'lib');
413 require $config_pm;
414 import Config;
415
416 die "$0: $config_pm not valid"
417         unless $Config{'CONFIGDOTSH'} eq 'true';
418
419 die "$0: error processing $config_pm"
420         if defined($Config{'an impossible name'})
421         or $Config{'CONFIGDOTSH'} ne 'true' # test cache
422         ;
423
424 die "$0: error processing $config_pm"
425         if eval '$Config{"cc"} = 1'
426         or eval 'delete $Config{"cc"}'
427         ;
428
429
430 exit 0;