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