config/gen/config_pm.pm

   1 # Copyright (C) 2001-2010, Parrot Foundation.
   2 # $Id$
   3
   4 =head1 NAME
   5
   6 config/gen/config_pm.pm - Record configuration data
   7
   8 =head1 DESCRIPTION
   9
  10 Writes the C<Parrot::Config::Generated> Perl module, the
  11 F<runtime/parrot/library/config.fpmc> generator program, and the F<myconfig>
  12 file.
  13
  14 =cut
  15
  16 package gen::config_pm;
  17
  18 use strict;
  19 use warnings;
  20
  21 use base qw(Parrot::Configure::Step);
  22 use Parrot::Configure::Utils ':gen';
  23
  24 use Cwd qw(cwd);
  25 use File::Spec::Functions qw(catdir);
  26
  27 sub _init {
  28     my $self = shift;
  29     my %data;
  30     $data{description} = q{Record configuration data for later retrieval};
  31     $data{result}      = q{};
  32     $data{templates}    = {
  33         myconfig        => 'config/gen/config_pm/myconfig.in',
  34         config_pir      => 'config/gen/config_pm/config_pir.in',
  35         Config_pm       => 'config/gen/config_pm/Config_pm.in',
  36         config_lib      => 'config/gen/config_pm/config_lib_pir.in',
  37     };
  38     return \%data;
  39 }
  40
  41 sub runstep {
  42     my ( $self, $conf ) = @_;
  43
  44     $conf->data->clean;
  45
  46     my $template = $self->{templates}->{myconfig};
  47     $conf->genfile($template, 'myconfig' );
  48
  49     $template = $self->{templates}->{config_pir};
  50     my $gen_pir = q{runtime/parrot/library/config.pir};
  51     $conf->append_configure_log($gen_pir);
  52     $conf->genfile($template, $gen_pir );
  53
  54     $template = $self->{templates}->{Config_pm};
  55     open( my $IN, "<", $template )
  56         or die "Can't open $template: $!";
  57
  58     my $configdir = catdir(qw/lib Parrot Config/);
  59     unless ( -d $configdir ) {
  60         mkdir $configdir
  61             or die "Can't create dir $configdir: $!";
  62     }
  63     my $gen_pm = q{lib/Parrot/Config/Generated.pm};
  64     $conf->append_configure_log($gen_pm);
  65     open( my $OUT, ">", $gen_pm )
  66         or die "Can't open $gen_pm: $!";
  67
  68     # escape spaces in current directory
  69     my $cwd = cwd();
  70     $cwd =~ s{ }{\\ }g;
  71
  72     # Build directory can have non ascii characters
  73     # Maybe not the better fix, but allows keep working on the issue.
  74     # See TT #1717
  75     my $cwdcharset = q{};
  76     if ($cwd =~ /[^[:ascii:]]/) {
  77         $cwdcharset = 'binary:';
  78     }
  79
  80     my $pkg = __PACKAGE__;
  81     print {$OUT} <<"END";
  82 # ex: set ro:
  83 # DO NOT EDIT THIS FILE
  84 # Generated by $pkg from $template
  85
  86 END
  87
  88     while (<$IN>) {
  89         s/\@PCONFIG\@/$conf->data->dump(q{c}, q{*PConfig})/e;
  90         s/\@PCONFIGTEMP\@/$conf->data->dump(q{c_temp}, q{*PConfig_Temp})/e;
  91         print {$OUT} $_;
  92     }
  93
  94     close $IN  or die "Can't close $template: $!";
  95     close $OUT or die "Can't close $gen_pm: $!";
  96
  97     $template = $self->{templates}->{config_lib};
  98     open( $IN,  "<", $template ) or die "Can't open '$template': $!";
  99     my $c_l_pir = q{config_lib.pir};
 100     $conf->append_configure_log($c_l_pir);
 101     open( $OUT, ">", $c_l_pir ) or die "Can't open $c_l_pir: $!";
 102
 103     print {$OUT} <<"END";
 104 # ex: set ro:
 105 # DO NOT EDIT THIS FILE
 106 # Generated by $pkg from $template and \%PConfig
 107 # This file should be the last thing run during
 108 # the make process, after Parrot is built.
 109
 110 END
 111
 112     my %p5_keys = map { $_ => 1 } $conf->data->keys_p5();
 113     # A few of these keys are still useful.
 114     my @p5_keys_whitelist = qw(archname ccflags longsize optimize);
 115     foreach my $key (@p5_keys_whitelist) {
 116         delete($p5_keys{$key});
 117     }
 118
 119     while (<$IN>) {
 120         if (/\@PCONFIG\@/) {
 121             for my $k ( sort { lc $a cmp lc $b || $a cmp $b } $conf->data->keys ) {
 122                 next if exists $p5_keys{$k};
 123                 next if $k =~ /_provisional$/;
 124
 125                 my $v = $conf->data->get($k);
 126                 if ( defined $v ) {
 127                     my $type = ref $v;
 128                     if ( $type ) {
 129                         die "type of '$k' is not supported : $type\n";
 130                     }
 131                     # String
 132                     $v =~ s/\\/\\\\/g;
 133                     $v =~ s/\\\\"/\\"/g;
 134                     # escape unescaped double quotes
 135                     $v =~ s/(?<!\\)"/\\"/g;
 136                     $v =~ s/\n/\\n/g;
 137                     my $charset = q{};
 138                     if ($v =~ /[^[:ascii:]]/) {
 139                         $charset = 'binary:';
 140                     }
 141                     print {$OUT} qq(    set \$P0["$k"], $charset"$v"\n);
 142                 }
 143                 else {
 144                     # Null
 145                     print {$OUT} qq(    set \$P0["$k"], \$S2\n);
 146                 }
 147             }
 148         }
 149         elsif (s/\"\@PWD\@\"/$cwdcharset\"$cwd\"/) {
 150             print {$OUT} $_;
 151         }
 152         else {
 153             print {$OUT} $_;
 154         }
 155     }
 156
 157     close $IN  or die "Can't close $template: $!";
 158     close $OUT or die "Can't close $c_l_pir: $!";
 159
 160     return 1;
 161 }
 162
 163 1;
 164
 165 # Local Variables:
 166 #   mode: cperl
 167 #   cperl-indent-level: 4
 168 #   fill-column: 100
 169 # End:
 170 # vim: expandtab shiftwidth=4: