config/auto/pmc.pm

   1 # Copyright (C) 2001-2008, The Perl Foundation.
   2 # $Id$
   3
   4 =head1 NAME
   5
   6 config/auto/pmc.pm - PMC Files
   7
   8 =head1 DESCRIPTION
   9
  10 Asks the user to select which PMC files to include.
  11
  12 =cut
  13
  14 package auto::pmc;
  15
  16 use strict;
  17 use warnings;
  18
  19 use base qw(Parrot::Configure::Step);
  20
  21 use File::Basename qw/basename/;
  22 use File::Spec::Functions qw/catfile/;
  23
  24 use Parrot::Configure::Utils ':auto';
  25
  26 sub _init {
  27     my $self = shift;
  28     return {
  29         description => 'Determining what pmc files should be compiled in',
  30         result      => '',
  31         PMC_PARENTS => {},
  32         srcpmc      => [ sort map { basename($_) } glob "./src/pmc/*.pmc" ],
  33     };
  34 }
  35
  36 # Return the (lowercased) name of the immediate parent of the given
  37 # (lowercased) pmc name.
  38 sub pmc_parent {
  39     my ($self, $pmc) = @_;
  40
  41     return $self->{PMC_PARENTS}{$pmc} if defined $self->{PMC_PARENTS}{$pmc};
  42
  43     local $/;
  44     open( my $PMC, '<', "src/pmc/$pmc.pmc" )
  45         or die "open src/pmc/$pmc.pmc failed: $!";
  46     local $_ = <$PMC>;
  47     close $PMC;
  48
  49     # Throw out everything but the pmclass declaration
  50     s/^.*?pmclass//s;
  51     s/\{.*$//s;
  52
  53     return $self->{PMC_PARENTS}{$pmc} = lc($1) if m/extends\s+(\w+)/;
  54     return $self->{PMC_PARENTS}{$pmc} = 'default';
  55 }
  56
  57 # Return an array of all
  58 sub pmc_parents {
  59     my ($self, $pmc) = @_;
  60
  61     my @parents = ($pmc);
  62     push @parents, $self->pmc_parent( $parents[-1] )
  63         until $parents[-1] eq 'default';
  64
  65     shift @parents;
  66     return @parents;
  67 }
  68
  69 sub get_pmc_order {
  70     open my $IN, '<', 'src/pmc/pmc.num' or die "Can't read src/pmc/pmc.num";
  71     my %order;
  72     while (<$IN>) {
  73         next if /^#/;
  74
  75         if (/(\w+\.\w+)\s+(\d+)/) {
  76             $order{$1} = $2;
  77         }
  78     }
  79
  80     close $IN;
  81
  82     return \%order;
  83 }
  84
  85 sub sort_pmcs {
  86     my @pmcs      = @_;
  87     my $pmc_order = get_pmc_order();
  88     my $n         = keys %$pmc_order;
  89     my @sorted_pmcs;
  90
  91     for my $pmc (@pmcs) {
  92         if ( exists $pmc_order->{$pmc} ) {
  93             $sorted_pmcs[ $pmc_order->{$pmc} ] = $pmc;
  94         }
  95         else {
  96             $sorted_pmcs[ $n++ ] = $pmc;
  97         }
  98     }
  99
 100     return @sorted_pmcs;
 101 }
 102
 103 sub contains_pccmethod {
 104     my $file = shift;
 105     open( my $fh, '<', $file ) or die "Can't read '$file': $!\n";
 106
 107     local $_;
 108     while (<$fh>) {
 109         next unless /METHOD/;
 110         return 1;
 111     }
 112
 113     return;
 114 }
 115
 116 # Given a PMC file name, get a list of all the includes it specifies
 117 sub get_includes {
 118     my $file = shift;
 119     open( my $fh, '<', $file ) or die "Can't read '$file': $!\n";
 120
 121     my @retval;
 122     local $_;
 123     while (<$fh>) {
 124         next unless /^\s*#include\s+["<](.*)[">]\s+$/;
 125         my $include = $1;
 126         if ($include =~ m{^(\.|parrot/)}) { # main parrot include dir
 127           $include = "include/" . $include;
 128         } elsif ($include =~ m/^pmc_|\.str$/) { # local pmc header
 129           $include = "src/pmc/" . $include;
 130         } # else it's probably a system header, don't depend on it.
 131         push @retval, $include;
 132     }
 133
 134     return join(' ', @retval);
 135 }
 136
 137
 138 sub runstep {
 139     my ( $self, $conf ) = @_;
 140
 141     my @pmc = sort_pmcs( @{ $self->{srcpmc} } );
 142
 143     my $pmc_list = $conf->options->get('pmc')
 144         || join( ' ', grep { defined $_ } @pmc );
 145
 146     # names of class files for src/pmc/Makefile
 147     ( my $TEMP_pmc_o   = $pmc_list ) =~ s/\.pmc/\$(O)/g;
 148     ( my $TEMP_pmc_str = $pmc_list ) =~ s/\.pmc/\.str/g;
 149
 150     # calls to pmc2c.pl for src/pmc/Makefile
 151     my $TEMP_pmc_build = <<"E_NOTE";
 152
 153 # the following part of the Makefile was built by 'config/auto/pmc.pm'
 154
 155 E_NOTE
 156
 157     $TEMP_pmc_build .= <<END;
 158 PMC2C_FILES = \\
 159     lib/Parrot/Pmc2c/Pmc2cMain.pm \\
 160     lib/Parrot/Pmc2c/Parser.pm \\
 161     lib/Parrot/Pmc2c/Dumper.pm \\
 162     lib/Parrot/Pmc2c/PMC.pm \\
 163     lib/Parrot/Pmc2c/Method.pm \\
 164     lib/Parrot/Pmc2c/PCCMETHOD.pm \\
 165     lib/Parrot/Pmc2c/PMCEmitter.pm \\
 166     lib/Parrot/Pmc2c/MethodEmitter.pm \\
 167     lib/Parrot/Pmc2c/Library.pm \\
 168     lib/Parrot/Pmc2c/UtilFunctions.pm \\
 169     lib/Parrot/Pmc2c/PMC/default.pm \\
 170     lib/Parrot/Pmc2c/PMC/delegate.pm \\
 171     lib/Parrot/Pmc2c/PMC/deleg_pmc.pm \\
 172     lib/Parrot/Pmc2c/PMC/Null.pm \\
 173     lib/Parrot/Pmc2c/PMC/Ref.pm \\
 174     lib/Parrot/Pmc2c/PMC/SharedRef.pm \\
 175     lib/Parrot/Pmc2c/PMC/STMRef.pm \\
 176     lib/Parrot/Pmc2c/PMC/RO.pm
 177 END
 178
 179     for my $pmc ( split( /\s+/, $pmc_list ) ) {
 180         $pmc =~ s/\.pmc$//;
 181         next if $pmc =~ /^const/;
 182
 183         # make each pmc depend upon its parent.
 184         my $parent_dumps = '';
 185         $parent_dumps .= "src/pmc/$_.dump "
 186             foreach reverse( ( $self->pmc_parents($pmc) ) );
 187         my $parent_headers = '';
 188         $parent_headers .= "src/pmc/pmc_$_.h "
 189             for $self->pmc_parents($pmc);
 190
 191         # add dependencies that result from METHOD usage.
 192         my $pmc_fname = catfile('src', 'pmc', "$pmc.pmc");
 193         my $pccmethod_depend = '';
 194         if (contains_pccmethod($pmc_fname)) {
 195             $pccmethod_depend = 'lib/Parrot/Pmc2c/PCCMETHOD.pm';
 196             if ($pmc ne 'fixedintegerarray') {
 197                 $pccmethod_depend .= ' src/pmc/pmc_fixedintegerarray.h';
 198             }
 199         }
 200         my $include_headers = get_includes($pmc_fname);
 201
 202         $TEMP_pmc_build .= <<END
 203 src/pmc/$pmc.c : src/pmc/$pmc.dump
 204 \t\$(PMC2CC) src/pmc/$pmc.pmc
 205
 206 src/pmc/$pmc.dump : vtable.dump $parent_dumps src/pmc/$pmc.pmc \$(PMC2C_FILES) $pccmethod_depend
 207 \t\$(PMC2CD) src/pmc/$pmc.pmc
 208
 209 src/pmc/pmc_$pmc.h: src/pmc/$pmc.c
 210
 211 src/pmc/$pmc\$(O): src/pmc/$pmc.str \$(NONGEN_HEADERS) \\
 212     $parent_headers $include_headers
 213
 214 END
 215     }
 216
 217     # src/pmc/$pmc\$(O): \$(NONGEN_HEADERS) $parent_headers src/pmc/pmc_$pmc.h
 218
 219     # build list of libraries for link line in Makefile
 220     my $slash = $conf->data->get('slash');
 221     ( my $TEMP_pmc_classes_o   = $TEMP_pmc_o )   =~ s/^| / src${slash}pmc${slash}/g;
 222     ( my $TEMP_pmc_classes_str = $TEMP_pmc_str ) =~ s/^| / src${slash}pmc${slash}/g;
 223     ( my $TEMP_pmc_classes_pmc = $pmc_list )     =~ s/^| / src${slash}pmc${slash}/g;
 224
 225     # Gather the actual names (with MixedCase) of all of the
 226     # non-abstract built-in PMCs.
 227     my @names;
 228 PMC: for my $pmc_file ( split( /\s+/, $pmc_list ) ) {
 229         next if $pmc_file =~ /^const/;
 230         my $name;
 231         open my $PMC, "<", "src/pmc/$pmc_file"
 232             or die "open src/pmc/$pmc_file: $!";
 233         my $const;
 234         while (<$PMC>) {
 235             if (/^pmclass (\w+)(.*)/) {
 236                 $name    = $1;
 237                 my $decl = $2;
 238                 $decl .= <$PMC> until $decl =~ s/\{.*//;
 239
 240                 $const = 1 if $decl =~ /\bconst_too\b/;
 241                 next PMC   if $decl =~ /\babstract\b/;
 242                 next PMC   if $decl =~ /\bextension\b/;
 243
 244                 last;
 245             }
 246         }
 247
 248         close $PMC;
 249
 250         die "No pmclass declaration found in $pmc_file"
 251             unless defined $name;
 252
 253         # please note that normal and Const PMCs must be in this order
 254         push @names, $name;
 255         push @names, "Const$name" if $const;
 256     }
 257
 258     $conf->data->set(
 259         pmc                  => $pmc_list,
 260         pmc_names            => join( ' ', @names ),
 261         TEMP_pmc_o           => $TEMP_pmc_o,
 262         TEMP_pmc_build       => $TEMP_pmc_build,
 263         TEMP_pmc_classes_o   => $TEMP_pmc_classes_o,
 264         TEMP_pmc_classes_str => $TEMP_pmc_classes_str,
 265         TEMP_pmc_classes_pmc => $TEMP_pmc_classes_pmc,
 266     );
 267
 268     return 1;
 269 }
 270
 271 1;
 272
 273 # Local Variables:
 274 #   mode: cperl
 275 #   cperl-indent-level: 4
 276 #   fill-column: 100
 277 # End:
 278 # vim: expandtab shiftwidth=4: