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