configpm

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