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