File Coverage

File:config/gen/config_pm.pm
Coverage:88.8%

linestmtbrancondsubcode
1# Copyright (C) 2001-2011, Parrot Foundation.
2
3 - 13
=head1 NAME

config/gen/config_pm.pm - Record configuration data

=head1 DESCRIPTION

Writes the C<Parrot::Config::Generated> Perl module, the
F<runtime/parrot/library/config.fpmc> generator program, and the F<myconfig>
file.

=cut
14
15package gen::config_pm;
16
17
2
2
2
2
use strict;
18
2
2
2
2
use warnings;
19
2
2
2
2
use Data::Dumper;$Data::Dumper::Indent=1;
20
2
2
2
2
use base qw(Parrot::Configure::Step);
21
2
2
2
2
use Parrot::Configure::Utils ':gen';
22
23
2
2
2
2
use Cwd qw(cwd);
24
2
2
2
2
use File::Spec::Functions qw(catdir);
25
26sub _init {
27
2
2
    my $self = shift;
28
2
    my %data;
29
2
    $data{description} = q{Record configuration data for later retrieval};
30
2
    $data{result} = q{};
31
2
    $data{templates} = {
32        myconfig => 'config/gen/config_pm/myconfig.in',
33        config_pir => 'config/gen/config_pm/config_pir.in',
34        Config_pm => 'config/gen/config_pm/Config_pm.in',
35        config_lib => 'config/gen/config_pm/config_lib_pir.in',
36    };
37
2
    return \%data;
38}
39
40sub runstep {
41
1
1
    my ( $self, $conf ) = @_;
42
43
1
    $conf->data->clean;
44
45
1
    my $template = $self->{templates}->{myconfig};
46
1
    $conf->genfile($template, 'myconfig' );
47
48
1
    $template = $self->{templates}->{config_pir};
49
1
    my $gen_pir = q{runtime/parrot/library/config.pir};
50
1
    $conf->append_configure_log($gen_pir);
51
1
    $conf->genfile($template, $gen_pir );
52
53
1
    $template = $self->{templates}->{Config_pm};
54
1
50
    open( my $IN, "<", $template )
55        or die "Can't open $template: $!";
56
57
1
    my $configdir = catdir(qw/lib Parrot Config/);
58
1
50
    unless ( -d $configdir ) {
59
0
0
        mkdir $configdir
60            or die "Can't create dir $configdir: $!";
61    }
62
1
    my $gen_pm = q{lib/Parrot/Config/Generated.pm};
63
1
    $conf->append_configure_log($gen_pm);
64
1
50
    open( my $OUT, ">", $gen_pm )
65        or die "Can't open $gen_pm: $!";
66
67    # add some keys convenient for embedders
68
1
    $conf->data->add( ' ', 'embed-cflags' =>
69        '-I' . $conf->data->get('includedir') . $conf->data->get('versiondir') );
70
1
    my $embed_ldflags_str = join(' ' => (
71        '-L' . $conf->data->get('libdir'),
72        '-lparrot',
73        $conf->data->get('icu_shared'),
74        $conf->data->get('libs'),
75    ) );
76
1
    $embed_ldflags_str =~ s/\s+/ /g;
77
1
    $embed_ldflags_str =~ s/\s+$//g;
78    # Eliminate duplicate entries
79
1
    my @embeds = split / /, $embed_ldflags_str;
80
1
    my %embeds_seen = ();
81
1
    my @deduped = ();
82
1
    for my $em (@embeds) {
83
19
100
        if (! $embeds_seen{$em}) {
84
15
            push @deduped, $em;
85
15
            $embeds_seen{$em}++;
86        }
87    }
88
1
    $conf->data->add( ' ', 'embed-ldflags' => join(' ' => @deduped) );
89
90
1
    my $cwd = cwd();
91
92    # expand msys virtual paths
93
1
50
    $cwd = `cd '$cwd' && pwd -W`, chomp $cwd
94        if $conf->data->get('osname') eq 'msys';
95
96    # escape spaces in current directory
97
1
    $cwd =~ s{ }{\\ }g;
98
99    # Build directory can have non ascii characters
100    # Maybe not the better fix, but allows keep working on the issue.
101    # See TT #1717
102
1
    my $cwdcharset = q{};
103
1
50
    if ($cwd =~ /[^[:ascii:]]/) {
104
0
        $cwdcharset = 'binary:';
105    }
106
107
1
    my $pkg = __PACKAGE__;
108
1
1
    print {$OUT} <<"END";
109# ex: set ro:
110# DO NOT EDIT THIS FILE
111# Generated by $pkg from $template
112
113END
114
115
1
    while (<$IN>) {
116
34
1
        s/\@PCONFIG\@/$conf->data->dump(q{c}, q{*PConfig})/e;
117
34
1
        s/\@PCONFIGTEMP\@/$conf->data->dump(q{c_temp}, q{*PConfig_Temp})/e;
118
34
34
        print {$OUT} $_;
119    }
120
121
1
50
    close $IN or die "Can't close $template: $!";
122
1
50
    close $OUT or die "Can't close $gen_pm: $!";
123
124
1
    $template = $self->{templates}->{config_lib};
125
1
50
    open( $IN, "<", $template ) or die "Can't open '$template': $!";
126
1
    my $c_l_pir = q{config_lib.pir};
127
1
    $conf->append_configure_log($c_l_pir);
128
1
50
    open( $OUT, ">", $c_l_pir ) or die "Can't open $c_l_pir: $!";
129
130
1
1
    print {$OUT} <<"END";
131# ex: set ro:
132# DO NOT EDIT THIS FILE
133# Generated by $pkg from $template and \%PConfig
134# This file should be the last thing run during
135# the make process, after Parrot is built.
136
137END
138
139
1
87
    my %p5_keys = map { $_ => 1 } $conf->data->keys_p5();
140    # A few of these keys are still useful.
141
1
    my @p5_keys_whitelist = qw(archname ccflags longsize optimize);
142
1
    foreach my $key (@p5_keys_whitelist) {
143
4
        delete($p5_keys{$key});
144    }
145
146
1
    while (<$IN>) {
147
38
100
100
        if (/\@PCONFIG\@/) {
148
149
1
1
            print {$OUT} qq( set \$P0["git_describe"], .PARROT_GIT_DESCRIBE\n);
150
1
1
            print {$OUT} qq( set \$P0["sha1"], .PARROT_SHA1\n);
151
152
1
2544
100
            for my $k ( sort { lc $a cmp lc $b || $a cmp $b } $conf->data->keys ) {
153
351
100
                next if exists $p5_keys{$k};
154
265
100
                next if $k =~ /_provisional$/;
155
156
256
                my $v = $conf->data->get($k);
157
256
100
                if ( defined $v ) {
158
249
                    my $type = ref $v;
159
249
50
                    if ( $type ) {
160
0
                        die "type of '$k' is not supported : $type\n";
161                    }
162                    # String
163
249
                    $v =~ s/\\/\\\\/g;
164
249
                    $v =~ s/\\\\"/\\"/g;
165                    # escape unescaped double quotes
166
249
                    $v =~ s/(?<!\\)"/\\"/g;
167
249
                    $v =~ s/\n/\\n/g;
168
249
                    my $charset = q{};
169
249
50
                    if ($v =~ /[^[:ascii:]]/) {
170
0
                        $charset = 'binary:';
171                    }
172
249
249
                    print {$OUT} qq( set \$P0["$k"], $charset"$v"\n);
173                }
174                else {
175                    # Null
176
7
7
                    print {$OUT} qq( set \$P0["$k"], \$S2\n);
177                }
178            }
179        }
180        elsif (s/\"\@PWD\@\"/$cwdcharset\"$cwd\"/) {
181
1
1
            print {$OUT} $_;
182        }
183        else {
184
36
36
            print {$OUT} $_;
185        }
186    }
187
188
1
50
    close $IN or die "Can't close $template: $!";
189
1
50
    close $OUT or die "Can't close $c_l_pir: $!";
190
191
1
    return 1;
192}
193
1941;
195
196# Local Variables:
197# mode: cperl
198# cperl-indent-level: 4
199# fill-column: 100
200# End:
201# vim: expandtab shiftwidth=4: