File Coverage

File:config/auto/pmc.pm
Coverage:93.6%

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

config/auto/pmc.pm - PMC Files

=head1 DESCRIPTION

Prepare PMC files for inclusion.

=cut
12
13package auto::pmc;
14
15
3
3
3
3
use strict;
16
3
3
3
3
use warnings;
17
18
3
3
3
3
use base qw(Parrot::Configure::Step);
19
20
3
3
3
3
use File::Basename qw/basename/;
21
3
3
3
3
use File::Spec::Functions qw/catfile/;
22
23
3
3
3
3
use Parrot::Configure::Utils ':auto';
24
25sub _init {
26
3
3
    my $self = shift;
27    return {
28
282
        description => 'Which pmc files should be compiled in',
29        result => '',
30        PMC_PARENTS => {},
31
3
        srcpmc => [ sort map { basename($_) } glob "./src/pmc/*.pmc" ],
32    };
33}
34
35sub runstep {
36
2
2
    my ( $self, $conf ) = @_;
37
38    # $pmc_list is a string holding a space-delimited list of currently active
39    # PMCs, sorted (largely) on the basis of src/pmc/pmc.num.
40    # (By 'current', we take into account the fact that there are PMCs listed
41    # in src/pmc/pmc.num that no longer exist but whose index numbers are
42    # never deleted.)
43
2
2
    my $pmc_list = get_sorted_pmc_str( @{ $self->{srcpmc} } );
44
45    # names of class files for src/pmc/Makefile
46
2
    ( my $TEMP_pmc_o = $pmc_list ) =~ s/\.pmc/\$(O)/g;
47
2
    ( my $TEMP_pmc_str = $pmc_list ) =~ s/\.pmc/\.str/g;
48
49    # calls to pmc2c.pl for src/pmc/Makefile
50
2
    my $TEMP_pmc_build = <<"E_NOTE";
51
52# the following part of the Makefile was built by 'config/auto/pmc.pm'
53
54E_NOTE
55
56
2
    $TEMP_pmc_build .= <<END;
57PMC2C_FILES = \\
58    lib/Parrot/Pmc2c/Pmc2cMain.pm \\
59    lib/Parrot/Pmc2c/Parser.pm \\
60    lib/Parrot/Pmc2c/Dumper.pm \\
61    lib/Parrot/Pmc2c/PMC.pm \\
62    lib/Parrot/Pmc2c/Method.pm \\
63    lib/Parrot/Pmc2c/PCCMETHOD.pm \\
64    lib/Parrot/Pmc2c/MULTI.pm \\
65    lib/Parrot/Pmc2c/Library.pm \\
66    lib/Parrot/Pmc2c/UtilFunctions.pm \\
67    lib/Parrot/Pmc2c/PMC/default.pm \\
68    lib/Parrot/Pmc2c/PMC/Null.pm \\
69    lib/Parrot/Pmc2c/PMC/RO.pm
70END
71
72
2
    my %universal_deps;
73
2
    while (<DATA>) {
74
118
100
        next if /^#/;
75
106
100
        next if /^\s*$/;
76
104
        chomp;
77
104
        $universal_deps{$_} = 1;
78    }
79
80
2
    for my $pmc ( split( /\s+/, $pmc_list ) ) {
81
188
        $pmc =~ s/\.pmc$//;
82
83        # make each pmc depend upon its parent.
84
188
        my $parent_dumps = '';
85        $parent_dumps .= "src/pmc/$_.dump "
86
188
            foreach reverse( ( $self->pmc_parents($pmc) ) );
87
188
        my $parent_headers = '';
88        $parent_headers .= "include/pmc/pmc_$_.h "
89
188
            for $self->pmc_parents($pmc);
90
91        # add dependencies that result from METHOD usage.
92
188
        my $pmc_fname = catfile('src', 'pmc', "$pmc.pmc");
93
188
        my $pccmethod_depend = '';
94
188
        my %o_deps = %universal_deps;
95
188
        $o_deps{"src/pmc/$pmc.c"} = 1;
96
188
        $o_deps{"src/pmc/$pmc.str"} = 1;
97
188
        $o_deps{"include/pmc/pmc_$pmc.h"} = 1;
98
99
188
100
        if (contains_pccmethod($pmc_fname)) {
100
124
            $pccmethod_depend = 'lib/Parrot/Pmc2c/PCCMETHOD.pm';
101
124
            $o_deps{"include/pmc/pmc_fixedintegerarray.h"} = 1;
102
124
100
            if ($pmc ne 'fixedintegerarray') {
103
122
                $pccmethod_depend .= ' include/pmc/pmc_fixedintegerarray.h';
104            }
105        }
106
107
188
        my $include_headers = get_includes($pmc_fname);
108
188
        my $cc_shared = $conf->data->get('cc_shared');
109
188
        my $cc_o_out = $conf->data->get('cc_o_out');
110
188
        my $warnings = $conf->data->get('ccwarn');
111
188
        my $optimize = $conf->data->get('optimize');
112
113
188
        foreach my $header (split ' ', $parent_headers) {
114
262
            $o_deps{$header} = 1;
115        }
116
188
        foreach my $header (split ' ', $include_headers) {
117
140
            $o_deps{$header} = 1;
118        }
119
120        # includes of includes
121        # (cheat. The right way to handle this is to do what
122        # checkdepend.t does.)
123
188
100
        if (exists $o_deps{'include/parrot/oplib/core_ops.h'} ) {
124
4
            $o_deps{'include/parrot/runcore_api.h'} = 1;
125        }
126
127
188
        my $o_deps = " " . join(" \\\n ", keys %o_deps);
128
188
        $TEMP_pmc_build .= <<END
129src/pmc/$pmc.c : src/pmc/$pmc.dump
130\t\$(PMC2CC) src/pmc/$pmc.pmc
131
132src/pmc/$pmc.dump : vtable.dump $parent_dumps src/pmc/$pmc.pmc \$(PMC2C_FILES) $pccmethod_depend
133\t\$(PMC2CD) src/pmc/$pmc.pmc
134
135include/pmc/pmc_$pmc.h: src/pmc/$pmc.c
136
137## SUFFIX OVERRIDE -Warnings
138src/pmc/$pmc\$(O): \\
139$o_deps
140\t\$(CC) \$(CFLAGS) $optimize $cc_shared $warnings -I\$(\@D) $cc_o_out\$@ -c src/pmc/$pmc.c
141
142END
143    }
144
145
146    # build list of libraries for link line in Makefile
147
2
    ( my $TEMP_pmc_classes_o = $TEMP_pmc_o ) =~ s{^| }{ src/pmc/}g;
148
2
    ( my $TEMP_pmc_classes_str = $TEMP_pmc_str ) =~ s{^| }{ src/pmc/}g;
149
2
    ( my $TEMP_pmc_classes_pmc = $pmc_list ) =~ s{^| }{ src/pmc/}g;
150
151    # Gather the actual names (with MixedCase) of all of the non-abstract
152    # built-in PMCs in rough hierarchical order.
153
2
    my %parents;
154
155
2
PMC: for my $pmc_file ( split( /\s+/, $pmc_list ) ) {
156
157
188
50
        open my $PMC, "<", "src/pmc/$pmc_file"
158            or die "open src/pmc/$pmc_file: $!";
159
160
188
        my ($const, $name);
161
162
188
        while (<$PMC>) {
163
20966
100
            if (/^pmclass (\w+)(.*)/) {
164
188
                $name = $1;
165
188
                my $decl = $2;
166
188
                $decl .= <$PMC> until $decl =~ s/\{.*//;
167
168
188
50
                $const = 1 if $decl =~ /\bconst_too\b/;
169
188
50
                next PMC if $decl =~ /\bextension\b/;
170
171                # the default PMC gets handled specially
172
188
100
                last if $name eq 'default';
173
174
186
                my $parent = 'default';
175
176
186
100
                if ($decl =~ /extends (\w+)/) {
177
68
                    $parent = $1;
178                }
179
180                # set a marker not to initialize an abstract PMC
181
186
50
                if ($decl =~ /\babstract\b/) {
182
0
0
                    unshift @{ $parents{$name} }, '(abstract)';
183                }
184
185                # please note that normal and Const PMCs must be in this order
186
186
186
                push @{ $parents{$parent} }, $name;
187
186
0
50
                push @{ $parents{$parent} }, "Const$name" if $const;
188
189
186
                last;
190            }
191        }
192
193
188
        close $PMC;
194
195
188
50
        die "No pmclass declaration found in $pmc_file"
196            unless defined $name;
197    }
198
199
2
    my @names = ('default', $self->order_pmcs_by_hierarchy( \%parents ));
200
201
2
    $conf->data->set(
202        pmc => $pmc_list,
203        pmc_names => join( ' ', @names ),
204        TEMP_pmc_o => $TEMP_pmc_o,
205        TEMP_pmc_build => $TEMP_pmc_build,
206        TEMP_pmc_classes_o => $TEMP_pmc_classes_o,
207        TEMP_pmc_classes_str => $TEMP_pmc_classes_str,
208        TEMP_pmc_classes_pmc => $TEMP_pmc_classes_pmc,
209    );
210
211
2
    return 1;
212}
213
214# Return the (lowercased) name of the immediate parent of the given
215# (lowercased) pmc name.
216sub pmc_parent {
217
524
524
    my ($self, $pmc) = @_;
218
219
524
100
    return $self->{PMC_PARENTS}{$pmc} if defined $self->{PMC_PARENTS}{$pmc};
220
221
186
    local $/;
222
186
50
    open( my $PMC, '<', "src/pmc/$pmc.pmc" )
223        or die "open src/pmc/$pmc.pmc failed: $!";
224
186
    local $_ = <$PMC>;
225
186
    close $PMC;
226
227    # Throw out everything but the pmclass declaration
228
186
    s/^.*?pmclass//s;
229
186
    s/\{.*$//s;
230
231
186
100
    return $self->{PMC_PARENTS}{$pmc} = lc($1) if m/extends\s+(\w+)/;
232
118
    return $self->{PMC_PARENTS}{$pmc} = 'default';
233}
234
235# Return an array of all
236sub pmc_parents {
237
376
376
    my ($self, $pmc) = @_;
238
239
376
    my @parents = ($pmc);
240
376
    push @parents, $self->pmc_parent( $parents[-1] )
241        until $parents[-1] eq 'default';
242
243
376
    shift @parents;
244
376
    return @parents;
245}
246
247# Internal sub get_pmc_order parses src/pmc/pmc.num. The hash it builds
248# includes both active and deactivated PMCs.
249sub get_pmc_order {
250
7
100
7
    open my $IN, '<', 'src/pmc/pmc.num' or die "Can't read src/pmc/pmc.num";
251
6
    my %order;
252
6
    while (<$IN>) {
253
186
100
        next unless (/^(\w+\.\w+)\s+(\d+)$/);
254
118
        $order{$1} = $2;
255    }
256
6
    close $IN;
257
6
    return \%order;
258}
259
260sub get_sorted_pmc_str {
261
4
4
    my @pmcs = @_;
262
4
    my $pmc_order = get_pmc_order();
263
4
    my $n = keys %$pmc_order;
264
4
    my @sorted_pmcs;
265
266
4
    for my $pmc (@pmcs) {
267
196
100
        if ( exists $pmc_order->{$pmc} ) {
268
68
            $sorted_pmcs[ $pmc_order->{$pmc} ] = $pmc;
269        }
270        else {
271
128
            $sorted_pmcs[ $n++ ] = $pmc;
272        }
273    }
274
275    # With the test for definedness below, we account for PMCs which have been
276    # deactivated but whose index numbers remain in src/pmc/pmc.num.
277
4
240
    my $active_pmcs = [ grep { defined $_ } @sorted_pmcs ];
278
279    # At this point we check to see whether any active_pmcs are missing from
280    # the MANIFEST. We warn about any such missing PMCs but (for the time
281    # being at least) we proceed to compose $pmc_str.
282
4
    my $seen_manifest = pmcs_in_manifest();
283
4
    check_pmcs_against_manifest( $active_pmcs, $seen_manifest );
284
4
4
    return join(' ' => @{ $active_pmcs });
285}
286
287sub pmcs_in_manifest {
288
6
100
6
    my $manifest = shift || 'MANIFEST';
289
6
    my %seen_manifest = ();
290
6
50
    open my $MAN, '<', $manifest
291        or die "Unable to open MANIFEST: $!";
292
6
    while (my $f = <$MAN>) {
293
6641
        chomp $f;
294
6641
100
        if ($f =~ m{^src/pmc/(.*\.pmc)}) {
295
293
            my $pmc = $1;
296
293
            $seen_manifest{$pmc}++;
297        }
298    }
299
6
50
    close $MAN or die "Unable to close MANIFEST: $!";
300
6
    return \%seen_manifest;
301}
302
303sub check_pmcs_against_manifest {
304
4
4
    my ($active_pmcs, $seen_manifest) = @_;
305
196
4
    my @missing_from_manifest = grep { ! exists $seen_manifest->{$_} }
306
4
        @{ $active_pmcs };
307
4
100
    if (@missing_from_manifest) {
308
1
        warn "PMCs found in /src/pmc not found in MANIFEST: @missing_from_manifest";
309    }
310}
311
312sub contains_pccmethod {
313
191
191
    my $file = shift;
314
191
100
    open( my $fh, '<', $file ) or die "Can't read '$file': $!\n";
315
316
190
    local $_;
317
190
    while (<$fh>) {
318
84362
100
        next unless /\bMETHOD\b/;
319
125
        return 1;
320    }
321
322
65
    return;
323}
324
325# Given a PMC file name, get a list of all the includes it specifies
326sub get_includes {
327
188
188
    my $file = shift;
328
188
50
    open( my $fh, '<', $file ) or die "Can't read '$file': $!\n";
329
330
188
    my @retval;
331
188
    local $_;
332
188
    while (<$fh>) {
333
107864
100
        next unless /^\s*# *include\s+"(.*)"\s+$/;
334
150
        my $include = $1;
335
150
100
100
100
100
50
        if ($include =~ m{^parrot}) { # main parrot include dir
336
62
100
          next if $include eq "parrot/parrot.h"; # already implicit everywhere.
337
54
100
          next if $include eq "parrot/io.h"; # already implicit everywhere.
338
52
          $include = "include/" . $include;
339        } elsif ($include =~ m/^pmc_|\.str$/) { # local pmc header
340
2
          $include = "src/pmc/" . $include;
341        } elsif ($include =~ m/^pmc\/pmc_/) { # local pmc header
342
72
          $include = "include/" . $include;
343        } elsif ($include =~ m/^imcc/) { # IMCC header.
344
4
            $include = "include/" . $include;
345        } elsif ($include =~ m{^\.\./}) { # relative to include/ dir...
346
10
          $include =~ s{^\.\./}{};
347        }
348
140
        push @retval, $include;
349    }
350
351
188
    return join(' ', @retval);
352}
353
354sub order_pmcs_by_hierarchy {
355
2
2
    my ($self, $parents) = @_;
356
357
2
    return $self->get_kids_for_parent( $parents, 'default' );
358}
359
360sub get_kids_for_parent {
361
188
188
    my ($self, $parents, $parent) = @_;
362
363
188
    my @kids;
364
365
188
188
    for my $kid (@{ $parents->{$parent} }) {
366        # skip abstract PMCs
367
186
50
        next if $kid eq '(abstract)';
368
186
50
67
        push @kids, $kid unless exists $parents->{$kid}
369                                && $parents->{$kid}[0] eq '(abstract)';
370
371        # and avoid infinite loops
372
186
50
        next if $kid eq $parent;
373
186
        push @kids, $self->get_kids_for_parent($parents, $kid);
374    }
375
376
188
    return @kids;
377}
378
3791;
380