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