More unpack cleanups.
[p5sagit/p5-mst-13.2.git] / configpm
1 #!./miniperl -w
2
3 # commonly used names to put first (and hence lookup fastest)
4 my %Common = map {($_,$_)}
5              qw(archname osname osvers prefix libs libpth
6                 dynamic_ext static_ext dlsrc so
7                 cc ccflags cppflags
8                 privlibexp archlibexp installprivlib installarchlib
9                 sharpbang startsh shsharp
10                );
11
12 # names of things which may need to have slashes changed to double-colons
13 my %Extensions = map {($_,$_)}
14                  qw(dynamic_ext static_ext extensions known_extensions);
15
16 # allowed opts as well as specifies default and initial values
17 my %Allowed_Opts = (
18     'cross'    => '', # --cross=PALTFORM - crosscompiling for PLATFORM
19     'glossary' => 1,  # --no-glossary  - no glossary file inclusion, 
20                       #                  for compactness
21 );
22
23 sub opts {
24     # user specified options
25     my %given_opts = (
26         # --opt=smth
27         (map {/^--([\-_\w]+)=(.*)$/} @ARGV),
28         # --opt --no-opt --noopt
29         (map {/^no-?(.*)$/i?($1=>0):($_=>1)} map {/^--([\-_\w]+)$/} @ARGV),
30     );
31
32     my %opts = (%Allowed_Opts, %given_opts);
33
34     for my $opt (grep {!exists $Allowed_Opts{$_}} keys %given_opts) {
35         die "option '$opt' is not recognized";
36     }
37     @ARGV = grep {!/^--/} @ARGV;
38
39     return %opts;
40 }
41
42
43 my %Opts = opts();
44
45 my $Config_PM;
46 my $Glossary = $ARGV[1] || 'Porting/Glossary';
47
48 if ($Opts{cross}) {
49   # creating cross-platform config file
50   mkdir "xlib";
51   mkdir "xlib/$Opts{cross}";
52   $Config_PM = $ARGV[0] || "xlib/$Opts{cross}/Config.pm";
53 }
54 else {
55   $Config_PM = $ARGV[0] || 'lib/Config.pm';
56 }
57
58
59 open CONFIG, ">$Config_PM" or die "Can't open $Config_PM: $!\n";
60
61 my $myver = sprintf "v%vd", $^V;
62
63 printf CONFIG <<'ENDOFBEG', ($myver) x 3;
64 # This file was created by configpm when Perl was built. Any changes
65 # made to this file will be lost the next time perl is built.
66
67 package Config;
68 @EXPORT = qw(%%Config);
69 @EXPORT_OK = qw(myconfig config_sh config_vars config_re);
70
71 my %%Export_Cache = map {($_ => 1)} (@EXPORT, @EXPORT_OK);
72
73 # Define our own import method to avoid pulling in the full Exporter:
74 sub import {
75     my $pkg = shift;
76     @_ = @EXPORT unless @_;
77
78     my @funcs = grep $_ ne '%%Config', @_;
79     my $export_Config = @funcs < @_ ? 1 : 0;
80
81     my $callpkg = caller(0);
82     foreach my $func (@funcs) {
83         die sprintf qq{"%%s" is not exported by the %%s module\n},
84             $func, __PACKAGE__ unless $Export_Cache{$func};
85         *{$callpkg.'::'.$func} = \&{$func};
86     }
87
88     *{"$callpkg\::Config"} = \%%Config if $export_Config;
89     return;
90 }
91
92 die "Perl lib version (%s) doesn't match executable version ($])"
93     unless $^V;
94
95 $^V eq %s
96     or die "Perl lib version (%s) doesn't match executable version (" .
97         sprintf("v%%vd",$^V) . ")";
98
99 ENDOFBEG
100
101
102 my @non_v    = ();
103 my @v_fast   = ();
104 my %v_fast   = ();
105 my @v_others = ();
106 my $in_v     = 0;
107 my %Data     = ();
108
109 # This is somewhat grim, but I want the code for parsing config.sh here and
110 # now so that I can expand $Config{ivsize} and $Config{ivtype}
111
112 my $fetch_string = <<'EOT';
113
114 # Search for it in the big string 
115 sub fetch_string {
116     my($self, $key) = @_;
117
118     my $quote_type = "'";
119     my $marker = "$key=";
120
121     # Check for the common case, ' delimited
122     my $start = index($Config_SH, "\n$marker$quote_type");
123     # If that failed, check for " delimited
124     if ($start == -1) {
125         $quote_type = '"';
126         $start = index($Config_SH, "\n$marker$quote_type");
127     }
128     return undef if ( ($start == -1) &&  # in case it's first 
129                       (substr($Config_SH, 0, length($marker)) ne $marker) );
130     if ($start == -1) { 
131         # It's the very first thing we found. Skip $start forward
132         # and figure out the quote mark after the =.
133         $start = length($marker) + 1;
134         $quote_type = substr($Config_SH, $start - 1, 1);
135     } 
136     else { 
137         $start += length($marker) + 2;
138     }
139
140     my $value = substr($Config_SH, $start, 
141                        index($Config_SH, "$quote_type\n", $start) - $start);
142
143     # If we had a double-quote, we'd better eval it so escape
144     # sequences and such can be interpolated. Since the incoming
145     # value is supposed to follow shell rules and not perl rules,
146     # we escape any perl variable markers
147     if ($quote_type eq '"') {
148         $value =~ s/\$/\\\$/g;
149         $value =~ s/\@/\\\@/g;
150         eval "\$value = \"$value\"";
151     }
152
153     # So we can say "if $Config{'foo'}".
154     $value = undef if $value eq 'undef';
155     $self->{$key} = $value; # cache it
156 }
157 EOT
158
159 eval $fetch_string;
160 die if $@;
161
162 open(CONFIG_SH, 'config.sh') || die "Can't open config.sh: $!";
163 while (<CONFIG_SH>) {
164     next if m:^#!/bin/sh:;
165
166     # Catch PERL_CONFIG_SH=true and PERL_VERSION=n line from Configure.
167     s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/ or m/^(\w+)='(.*)'$/;
168     my($k, $v) = ($1, $2);
169
170     # grandfather PATCHLEVEL and SUBVERSION and CONFIG
171     if ($k) {
172         if ($k eq 'PERL_VERSION') {
173             push @v_others, "PATCHLEVEL='$v'\n";
174         }
175         elsif ($k eq 'PERL_SUBVERSION') {
176             push @v_others, "SUBVERSION='$v'\n";
177         }
178         elsif ($k eq 'PERL_CONFIG_SH') {
179             push @v_others, "CONFIG='$v'\n";
180         }
181     }
182
183     # We can delimit things in config.sh with either ' or ". 
184     unless ($in_v or m/^(\w+)=(['"])(.*\n)/){
185         push(@non_v, "#$_"); # not a name='value' line
186         next;
187     }
188     $quote = $2;
189     if ($in_v) { 
190         $val .= $_;
191     }
192     else { 
193         ($name,$val) = ($1,$3); 
194     }
195     $in_v = $val !~ /$quote\n/;
196     next if $in_v;
197
198     s,/,::,g if $Extensions{$name};
199
200     $val =~ s/$quote\n?\z//;
201
202     my $line = "$name=$quote$val$quote\n";
203     if (!$Common{$name}){
204         push(@v_others, $line);
205     }
206     else {
207         push(@v_fast, $line);
208         $v_fast{$name} = "'$name' => $quote$val$quote";
209     }
210 }
211 close CONFIG_SH;
212
213 print CONFIG @non_v, "\n";
214
215 # copy config summary format from the myconfig.SH script
216 print CONFIG "our \$summary : unique = <<'!END!';\n";
217 open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
218 1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
219 do { print CONFIG $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
220 close(MYCONFIG);
221
222 # NB. as $summary is unique, we need to copy it in a lexical variable
223 # before expanding it, because may have been made readonly if a perl
224 # interpreter has been cloned.
225
226 print CONFIG "\n!END!\n", <<'EOT';
227 my $summary_expanded;
228
229 sub myconfig {
230     return $summary_expanded if $summary_expanded;
231     ($summary_expanded = $summary) =~ s{\$(\w+)}
232                  { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge;
233     $summary_expanded;
234 }
235
236 our $Config_SH : unique = <<'!END!';
237 EOT
238
239 print CONFIG join("", @v_fast, sort @v_others);
240
241 print CONFIG "!END!\n", $fetch_string;
242
243 print CONFIG <<'ENDOFEND';
244
245 sub fetch_virtual {
246     my($self, $key) = @_;
247
248     my $value;
249
250     if ($key =~ /^((?:cc|ld)flags|libs(?:wanted)?)_nolargefiles/) {
251         # These are purely virtual, they do not exist, but need to
252         # be computed on demand for largefile-incapable extensions.
253         my $new_key = "${1}_uselargefiles";
254         $value = $Config{$1};
255         my $withlargefiles = $Config{$new_key};
256         if ($new_key =~ /^(?:cc|ld)flags_/) {
257             $value =~ s/\Q$withlargefiles\E\b//;
258         } elsif ($new_key =~ /^libs/) {
259             my @lflibswanted = split(' ', $Config{libswanted_uselargefiles});
260             if (@lflibswanted) {
261                 my %lflibswanted;
262                 @lflibswanted{@lflibswanted} = ();
263                 if ($new_key =~ /^libs_/) {
264                     my @libs = grep { /^-l(.+)/ &&
265                                       not exists $lflibswanted{$1} }
266                                     split(' ', $Config{libs});
267                     $Config{libs} = join(' ', @libs);
268                 } elsif ($new_key =~ /^libswanted_/) {
269                     my @libswanted = grep { not exists $lflibswanted{$_} }
270                                           split(' ', $Config{libswanted});
271                     $Config{libswanted} = join(' ', @libswanted);
272                 }
273             }
274         }
275     }
276
277     $self->{$key} = $value;
278 }
279
280 sub FETCH { 
281     my($self, $key) = @_;
282
283     # check for cached value (which may be undef so we use exists not defined)
284     return $self->{$key} if exists $self->{$key};
285
286     $self->fetch_string($key);
287     return $self->{$key} if exists $self->{$key};
288     $self->fetch_virtual($key);
289
290     # Might not exist, in which undef is correct.
291     return $self->{$key};
292 }
293  
294 my $prevpos = 0;
295
296 sub FIRSTKEY {
297     $prevpos = 0;
298     substr($Config_SH, 0, index($Config_SH, '=') );
299 }
300
301 sub NEXTKEY {
302     # Find out how the current key's quoted so we can skip to its end.
303     my $quote = substr($Config_SH, index($Config_SH, "=", $prevpos)+1, 1);
304     my $pos = index($Config_SH, qq($quote\n), $prevpos) + 2;
305     my $len = index($Config_SH, "=", $pos) - $pos;
306     $prevpos = $pos;
307     $len > 0 ? substr($Config_SH, $pos, $len) : undef;
308 }
309
310 sub EXISTS { 
311     return 1 if exists($_[0]->{$_[1]});
312
313     return(index($Config_SH, "\n$_[1]='") != -1 or
314            substr($Config_SH, 0, length($_[1])+2) eq "$_[1]='" or
315            index($Config_SH, "\n$_[1]=\"") != -1 or
316            substr($Config_SH, 0, length($_[1])+2) eq "$_[1]=\"" or
317            $_[1] =~ /^(?:(?:cc|ld)flags|libs(?:wanted)?)_nolargefiles$/
318           );
319 }
320
321 sub STORE  { die "\%Config::Config is read-only\n" }
322 *DELETE = \&STORE;
323 *CLEAR  = \&STORE;
324
325
326 sub config_sh {
327     $Config_SH
328 }
329
330 sub config_re {
331     my $re = shift;
332     return map { chomp; $_ } grep /^$re=/, split /^/, $Config_SH;
333 }
334
335 sub config_vars {
336     foreach (@_) {
337         if (/\W/) {
338             my @matches = config_re($_);
339             print map "$_\n", @matches ? @matches : "$_: not found";
340         } else {
341             my $v = (exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
342             $v = 'undef' unless defined $v;
343             print "$_='$v';\n";
344         }
345     }
346 }
347
348 ENDOFEND
349
350 if ($^O eq 'os2') {
351     print CONFIG <<'ENDOFSET';
352 my %preconfig;
353 if ($OS2::is_aout) {
354     my ($value, $v) = $Config_SH =~ m/^used_aout='(.*)'\s*$/m;
355     for (split ' ', $value) {
356         ($v) = $Config_SH =~ m/^aout_$_='(.*)'\s*$/m;
357         $preconfig{$_} = $v eq 'undef' ? undef : $v;
358     }
359 }
360 $preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
361 sub TIEHASH { bless {%preconfig} }
362 ENDOFSET
363     # Extract the name of the DLL from the makefile to avoid duplication
364     my ($f) = grep -r, qw(GNUMakefile Makefile);
365     my $dll;
366     if (open my $fh, '<', $f) {
367         while (<$fh>) {
368             $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
369         }
370     }
371     print CONFIG <<ENDOFSET if $dll;
372 \$preconfig{dll_name} = '$dll';
373 ENDOFSET
374 } else {
375     print CONFIG <<'ENDOFSET';
376 sub TIEHASH {
377     bless $_[1], $_[0];
378 }
379 ENDOFSET
380 }
381
382
383 # Calculation for the keys for byteorder
384 # This is somewhat grim, but I need to run fetch_string here.
385 our $Config_SH = join "\n", @v_fast, @v_others;
386
387 my $t = fetch_string ({}, 'ivtype');
388 my $s = fetch_string ({}, 'ivsize');
389
390 # byteorder does exist on its own but we overlay a virtual
391 # dynamically recomputed value.
392
393 # However, ivtype and ivsize will not vary for sane fat binaries
394
395 my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I';
396
397 my $byteorder_code;
398 if ($s == 4 || $s == 8) {
399     my $list = join ',', reverse(2..$s);
400     my $format = 'a'x$s;
401     $byteorder_code = <<"EOT";
402 my \$i = 0;
403 foreach my \$c ($list) { \$i |= ord(\$c); \$i <<= 8 }
404 \$i |= ord(1);
405 my \$value = join('', unpack('$format', pack('$f', \$i)));
406 EOT
407 } else {
408     $byteorder_code = "\$value = '?'x$s;\n";
409 }
410
411 my $fast_config = join '', map { "    $_,\n" }
412     sort values (%v_fast), 'byteorder => $value' ;
413
414 print CONFIG sprintf <<'ENDOFTIE', $byteorder_code, $fast_config;
415
416 # avoid Config..Exporter..UNIVERSAL search for DESTROY then AUTOLOAD
417 sub DESTROY { }
418
419 %s
420
421 tie %%Config, 'Config', {
422 %s
423 };
424
425 1;
426 ENDOFTIE
427
428
429 open(CONFIG_POD, ">lib/Config.pod") or die "Can't open lib/Config.pod: $!";
430 print CONFIG_POD <<'ENDOFTAIL';
431 =head1 NAME
432
433 Config - access Perl configuration information
434
435 =head1 SYNOPSIS
436
437     use Config;
438     if ($Config{'cc'} =~ /gcc/) {
439         print "built by gcc\n";
440     } 
441
442     use Config qw(myconfig config_sh config_vars config_re);
443
444     print myconfig();
445
446     print config_sh();
447
448     print config_re();
449
450     config_vars(qw(osname archname));
451
452
453 =head1 DESCRIPTION
454
455 The Config module contains all the information that was available to
456 the C<Configure> program at Perl build time (over 900 values).
457
458 Shell variables from the F<config.sh> file (written by Configure) are
459 stored in the readonly-variable C<%Config>, indexed by their names.
460
461 Values stored in config.sh as 'undef' are returned as undefined
462 values.  The perl C<exists> function can be used to check if a
463 named variable exists.
464
465 =over 4
466
467 =item myconfig()
468
469 Returns a textual summary of the major perl configuration values.
470 See also C<-V> in L<perlrun/Switches>.
471
472 =item config_sh()
473
474 Returns the entire perl configuration information in the form of the
475 original config.sh shell variable assignment script.
476
477 =item config_re($regex)
478
479 Like config_sh() but returns, as a list, only the config entries who's
480 names match the $regex.
481
482 =item config_vars(@names)
483
484 Prints to STDOUT the values of the named configuration variable. Each is
485 printed on a separate line in the form:
486
487   name='value';
488
489 Names which are unknown are output as C<name='UNKNOWN';>.
490 See also C<-V:name> in L<perlrun/Switches>.
491
492 =back
493
494 =head1 EXAMPLE
495
496 Here's a more sophisticated example of using %Config:
497
498     use Config;
499     use strict;
500
501     my %sig_num;
502     my @sig_name;
503     unless($Config{sig_name} && $Config{sig_num}) {
504         die "No sigs?";
505     } else {
506         my @names = split ' ', $Config{sig_name};
507         @sig_num{@names} = split ' ', $Config{sig_num};
508         foreach (@names) {
509             $sig_name[$sig_num{$_}] ||= $_;
510         }   
511     }
512
513     print "signal #17 = $sig_name[17]\n";
514     if ($sig_num{ALRM}) { 
515         print "SIGALRM is $sig_num{ALRM}\n";
516     }   
517
518 =head1 WARNING
519
520 Because this information is not stored within the perl executable
521 itself it is possible (but unlikely) that the information does not
522 relate to the actual perl binary which is being used to access it.
523
524 The Config module is installed into the architecture and version
525 specific library directory ($Config{installarchlib}) and it checks the
526 perl version number when loaded.
527
528 The values stored in config.sh may be either single-quoted or
529 double-quoted. Double-quoted strings are handy for those cases where you
530 need to include escape sequences in the strings. To avoid runtime variable
531 interpolation, any C<$> and C<@> characters are replaced by C<\$> and
532 C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
533 or C<\@> in double-quoted strings unless you're willing to deal with the
534 consequences. (The slashes will end up escaped and the C<$> or C<@> will
535 trigger variable interpolation)
536
537 =head1 GLOSSARY
538
539 Most C<Config> variables are determined by the C<Configure> script
540 on platforms supported by it (which is most UNIX platforms).  Some
541 platforms have custom-made C<Config> variables, and may thus not have
542 some of the variables described below, or may have extraneous variables
543 specific to that particular port.  See the port specific documentation
544 in such cases.
545
546 ENDOFTAIL
547
548 if ($Opts{glossary}) {
549   open(GLOS, "<$Glossary") or die "Can't open $Glossary: $!";
550 }
551 %seen = ();
552 $text = 0;
553 $/ = '';
554
555 sub process {
556   if (s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m) {
557     my $c = substr $1, 0, 1;
558     unless ($seen{$c}++) {
559       print CONFIG_POD <<EOF if $text;
560 =back
561
562 EOF
563       print CONFIG_POD <<EOF;
564 =head2 $c
565
566 =over 4
567
568 EOF
569      $text = 1;
570     }
571   }
572   elsif (!$text || !/\A\t/) {
573     warn "Expected a Configure variable header",
574       ($text ? " or another paragraph of description" : () );
575   }
576   s/n't/n\00t/g;                # leave can't, won't etc untouched
577   s/^\t\s+(.*)/\n$1/gm;         # Indented lines ===> new paragraph
578   s/^(?<!\n\n)\t(.*)/$1/gm;     # Not indented lines ===> text
579   s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
580   s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
581   s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
582   s{
583      (?<! [\w./<\'\"] )         # Only standalone file names
584      (?! e \. g \. )            # Not e.g.
585      (?! \. \. \. )             # Not ...
586      (?! \d )                   # Not 5.004
587      (?! read/ )                # Not read/write
588      (?! etc\. )                # Not etc.
589      (?! I/O )                  # Not I/O
590      (
591         \$ ?                    # Allow leading $
592         [\w./]* [./] [\w./]*    # Require . or / inside
593      )
594      (?<! \. (?= [\s)] ) )      # Do not include trailing dot
595      (?! [\w/] )                # Include all of it
596    }
597    (F<$1>)xg;                   # /usr/local
598   s/((?<=\s)~\w*)/F<$1>/g;      # ~name
599   s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g;    # UNISTD
600   s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
601   s/n[\0]t/n't/g;               # undo can't, won't damage
602 }
603
604 if ($Opts{glossary}) {
605     <GLOS>;                             # Skip the "DO NOT EDIT"
606     <GLOS>;                             # Skip the preamble
607   while (<GLOS>) {
608     process;
609     print CONFIG_POD;
610   }
611 }
612
613 print CONFIG_POD <<'ENDOFTAIL';
614
615 =back
616
617 =head1 NOTE
618
619 This module contains a good example of how to use tie to implement a
620 cache and an example of how to make a tied variable readonly to those
621 outside of it.
622
623 =cut
624
625 ENDOFTAIL
626
627 close(CONFIG);
628 close(GLOS);
629 close(CONFIG_POD);
630
631 # Now create Cross.pm if needed
632 if ($Opts{cross}) {
633   open CROSS, ">lib/Cross.pm" or die "Can not open >lib/Cross.pm: $!";
634   my $cross = <<'EOS';
635 # typical invocation:
636 #   perl -MCross Makefile.PL
637 #   perl -MCross=wince -V:cc
638 package Cross;
639
640 sub import {
641   my ($package,$platform) = @_;
642   unless (defined $platform) {
643     # if $platform is not specified, then use last one when
644     # 'configpm; was invoked with --cross option
645     $platform = '***replace-marker***';
646   }
647   @INC = map {/\blib\b/?(do{local $_=$_;s/\blib\b/xlib\/$platform/;$_},$_):($_)} @INC;
648   $::Cross::platform = $platform;
649 }
650
651 1;
652 EOS
653   $cross =~ s/\*\*\*replace-marker\*\*\*/$Opts{cross}/g;
654   print CROSS $cross;
655   close CROSS;
656 }
657
658 # Now do some simple tests on the Config.pm file we have created
659 unshift(@INC,'lib');
660 require $Config_PM;
661 import Config;
662
663 die "$0: $Config_PM not valid"
664         unless $Config{'PERL_CONFIG_SH'} eq 'true';
665
666 die "$0: error processing $Config_PM"
667         if defined($Config{'an impossible name'})
668         or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
669         ;
670
671 die "$0: error processing $Config_PM"
672         if eval '$Config{"cc"} = 1'
673         or eval 'delete $Config{"cc"}'
674         ;
675
676
677 exit 0;