On Mon Dec 25 22:14:18 2006, [EMAIL PROTECTED] wrote:
> A few style comments here.
> [snip]
>
> > sub dump_vtable {
> > my $self = shift;
> > my $file = shift;
>
> Why two shifts here, when @_ goes unused through the rest of the method?
Fixed in attached patch: Utils.pm.
>
> > sub print_tree {
> > my $self = shift;
> > my $argsref = shift;
>
> Ditto here.
>
Ditto.
The attached Utils.pm and 04-dump_pmc.t supersede those I uploaded last night.
Apart
from responding to some of chromatic's suggestions, they provide additional
tests to
improve test coverage (http://thenceforward.net/parrot/cover_db/coverage.html).
kid51
# Copyright (C) 2004-2006, The Perl Foundation.
# $Id: Parrot::Pmc2c::Utils.pm 15044 2006-10-29 00:00:11Z jonathan $
package Parrot::Pmc2c::Utils;
use strict;
use warnings;
use FindBin;
use Data::Dumper;
use Parrot::Vtable;
use Parrot::Pmc2c::Library;
use Parrot::Pmc2c qw(count_newlines);
use Cwd qw(cwd realpath);
use File::Basename;
=head1 NAME
Parrot::Pmc2c::Utils - Functions called within F<tools/build/pmc2c.pl>
=head1 SYNOPSIS
use Parrot::Pmc2c::Utils;
=head1 DESCRIPTION
Parrot::Pmc2c::Utils holds subroutines called within F<tools/build/pmc2c.pl>.
=cut
=head1 FUNCTIONS
=head2 Publicly Available Methods
=head3 C<new()>
$self = Parrot::Pmc2c::Utils->new( {
include => [EMAIL PROTECTED],
opt => \%opt,
args => [EMAIL PROTECTED],
} );
B<Purpose:> Parrot::Pmc2c::Utils constructor.
B<Arguments:> Reference to a hash holding 3 required keys:
=over 4
=item * C<include>
Array reference. Array passed holds list of paths in which various methods
should try to locate files.
=item * C<opt>
Hash reference. Holds results of processing of options to C<pmc2c.pl()>.
=item * C<args>
Array reference. In most cases, the array passed will hold the elements of
C<@ARGV> remaining after options processing.
=back
B<Return Values:> Parrot::Pmc2c::Utils object. Will C<die> with error
message if arguments are defective.
=cut
sub new {
my ($class, $allargsref) = @_;
die "Must pass a hash ref to Parrot::Pmc2c::Utils::new"
unless ref($allargsref) eq q{HASH};
die "Must have key 'include' which is a reference to an array of directories"
unless (defined $allargsref->{include} and ref($allargsref->{include}) eq q{ARRAY});
die "Must have key 'opt' which is a reference to a hash of option values"
unless (defined $allargsref->{opt} and ref($allargsref->{opt}) eq q{HASH});
die "Must have key 'args' which is a reference to a list of the remaining arguments"
unless (defined $allargsref->{args} and
ref($allargsref->{args}) eq q{ARRAY}
);
unshift @{$allargsref->{include}}, (
".",
"$FindBin::Bin/../..",
"$FindBin::Bin/../../src/pmc/"
);
foreach my $opt qw(nobody nolines debug verbose) {
if (! defined $allargsref->{opt}{$opt}) {
$allargsref->{opt}{$opt} = 0;
}
}
return bless( $allargsref, $class );
}
=head3 C<get_included_paths()>
@included = $self->get_included_paths()
B<Purpose:> Accessor to C<include> key inside Parrot::Pmc2c::Utils object.
B<Arguments:> None.
B<Return Values:> List referenced by the value of the C<include> key in
the hash passed by reference to C<Parrot::Pmc2c::Utils->new()>.
B<Comment:> Used internally in C<find_file()>.
=cut
sub get_included_paths {
my $self = shift;
return @{$self->{include}};
}
=head3 C<find_file()>
$path = $self->find_file($file, $die_unless_found_flag);
B<Purpose:> Return the full path to C<$file>. (Search in the directories
listed in the C<include> key in the hash passed by reference to the
constructor). Optionally, die with an error message if that file cannot
be found.
B<Arguments:> Two arguments. Required: string holding name of the file
sought. Optional: a flag variable which, if set to a true value, will cause
program to die if file is not located.
B<Return Values:> Upon success, string holding a path. Upon failure,
C<undef> (unless C<$die_unless_found_flag> is set to a true value, in which
case program C<die>s).
B<Comment:> Called inside C<read_dump()> and C<dump_pmc()>.
=cut
sub find_file {
my ($self, $file, $die_unless_found) = @_;
if (File::Spec->file_name_is_absolute($file) && -e $file) {
return $file;
}
my @includes = $self->get_included_paths();
foreach my $dir ( @includes ) {
my $path = File::Spec->catfile( $dir, $file );
return $path if -e $path;
}
die "cannot find file '$file' in path '", join("', '", @includes), "'"
if $die_unless_found;
return;
}
=head3 C<dump_vtable()>
$self->dump_vtable("$FindBin::Bin/../../vtable.tbl");
B<Purpose:> Create a F<.dump> file for the default vtable (from which
all PMCs inherit).
B<Arguments:> Scalar holding filename of vtable.
B<Return Values:> Scalar holding path to F<.dump> file.
B<Comments:> In earlier version of F<pmc2c.pl>, this subroutine returned
C<undef> upon success. This was changed to more Perl-ish C<1>.
If the caller of this subroutine has C<chdir>-ed to a tempdir before this
subroutine is called -- as ought to be the case during testing of build
tools -- then F<vtable.dump> will be created within that tempdir.
Otherwise, F<vtable.dump> is created in the caller's working directory.
When the caller is F<make>, that directory is the top-level Parrot directory.
=cut
sub dump_vtable {
my ($self, $file) = @_;
my $default = parse_vtable($file);
my $dump = $file;
$dump =~ s/\.\w+$/\.dump/;
$dump = cwd() . q{/} . basename($dump);
my $vtd = open_file( ">", $dump, $self->{opt}{verbose} );
my %vtable = (
flags => {},
pre => '',
post => '',
);
my %meth_hash;
my $i = 0;
foreach my $entry (@$default) {
$meth_hash{$entry->[1]} = $i++;
push @{$vtable{methods}},
{
parameters => $entry->[2],
meth => $entry->[1],
type => $entry->[0],
section => $entry->[3],
mmd => $entry->[4],
attr => $entry->[5]
};
}
$vtable{'has_method'} = \%meth_hash;
my $Dumper = Data::Dumper->new([\%vtable], ['class']);
$Dumper->Indent(3);
print $vtd $Dumper->Dump();
close $vtd;
return $dump;
}
=head3 C<print_tree()>
$self->print_tree( {
depth => 0,
files => [ @files_to_be_printed ], # optional
} );
B<Purpose:> Print the inheritance tree for each of the files, using the
given directories to search for all of correct PMCs.
B<Arguments:> Reference to hash holding key-value pairs.
=over 4
=item * depth
Number holding the display depth. Used for the recursive
definition of this function. Defaults to C<0> if not specified.
=item * files
Optional. Reference to an array holding a list of files. If not supplied, the
value of the C<args> key in C<Parrot::Pmc2c::Utils::new()> will be used.
(This is used for the recursive call.)
=back
B<Return Values:> C<1> upon successful printing.
B<Comment:> In earlier version of F<pmc2c.pl>, this subroutine returned
C<undef> upon success. This was changed to more Perl-ish C<1>.
The purpose of this method is unclear. (1) It is not called by Makefile. (2)
Since internally calls read_dump(), a F<.dump> file must already exist for
this method to generate meaningful output. But since F<.dump> files do B<not>
exist prior to calling F<make>, this can only be viewed as an attempt at a
utility method to be called B<after> F<make> has run. That might be useful.
It would be responding to a request such as, "Given these F<.dump> files,
reconstruct the inheritance trees of their ancestral F<.pmc> files." But
that's a very different purpose from the other methods in this program, whose
point is to go from F<.pmc> to F<.c> files.
=cut
sub print_tree {
my ($self, $argsref) = @_;
my $depth = $argsref->{depth} || 0;
my @files;
# First, look for list of files provided as argument to 'files' key in
# hash passed by ref to this method call.
if (defined $argsref->{files}) {
die "Value of 'files' key in call to print_tree() must be array ref"
unless ref($argsref->{files}) eq 'ARRAY';
die "Array ref which is value of 'files' key in call to print_tree() must hold positive number of files"
unless scalar(@{$argsref->{files}});
@files = @{$argsref->{files}};
# Next, look for list of files provided as argument to 'args' key of
# constructor.
} else {
if (@{$self->{args}}) {
@files = @{$self->{args}};
} else {
die "print_tree() lacked files to print; nothing in constructor's 'args' key";
}
}
for my $f (@files) {
my $class = $self->read_dump($f);
print " " x $depth, $class->{class}, "\n";
for my $k (keys %{$class->{flags}{extends}}) {
$self->print_tree( {
depth => $depth + 1,
files => [ lc("$k.pmc") ],
} );
}
}
return 1;
}
=head3 C<read_dump()>
$self->read_dump('filename');
B<Purpose:> A F<.dump> file is the result of a call to C<dump_pmc()> and
consists of a print-out of a hash reference Data::Dumper-style.
C<read_dump()> reads in the F<.dump> file, recreates the data structure and
returns a new hash reference holding the data structure.
B<Arguments:> Scalar holding name of file whose structure is to be dumped.
The method will only process F<foo.dump> files, but you can also pass
C<'foo.c'> or C<'foo.pmc'> as the argument and it will analyze the
corresponding F<foo.dump> file.
B<Return Values:> Reference to hash holding recreated data structure.
B<Comment:> If the appropriate F<.dump> file cannot be located, program
will die with error message (see C<find_file()> above).
Called internally by C<print_tree()>, C<gen_c()>, C<gen_parent_list()>,
C<dump_pmc()>.
=cut
sub read_dump {
my ($self, $file) = @_;
$file =~ s/\.\w+$/.dump/;
$file = $self->find_file($file, 1);
my $fh = open_file( "<", $file, $self->{opt}{verbose});
my $class;
eval do { local $/; <$fh> };
die $@ if $@;
close $fh;
return $class;
}
=head3 C<gen_c()>
$return_value = $self->gen_c();
B<Purpose:> Generate the C source code file for each of the files passed in,
using the directories passed in to search for the PMC dump files.
B<Arguments:> None.
B<Return Values:> Returns C<1> upon success.
B<Comment:> Internally calls C<Parrot::Pmc2c::Library::new()> and
C<write_all_files()>. In earlier version of F<pmc2c.pl>, this
subroutine returned C<undef> upon success. This was changed to more
Perl-ish C<1>.
=cut
sub gen_c {
my $self = shift;
my @files = @{$self->{args}};
my $optsref = $self->{opt};
my %pmcs = map { $_, $self->read_dump($_) } @files;
Parrot::Pmc2c::Library
->new( $optsref, $self->read_dump("vtable.pmc"), %pmcs )
->write_all_files;
return 1;
}
=head3 C<dump_pmc()>
$return_value = $self->dump_pmc();
B<Purpose:> Create a F<.dump> file for each file listed in the constructor's
C<arg> key (which can be found in the directories listed in the C<include> key).
A C<'*.pmc'> glob may also be passed to emulate a proper shell in the presence
of a dumb one.
$self = Parrot::Pmc2c::Utils->new( {
include => [EMAIL PROTECTED],
opt => \%opt,
args => [ ( q{*.pmc} ) ],
} );
$self->dump_pmc();
B<Arguments:> None.
B<Return Values:> Returns 1 upon success.
B<Comments:> Called when C<--dump> is specified as the command-line option to
F<pmc2c.pl>.
=cut
sub dump_pmc {
my $self = shift;
my $include = $self->{include};
my @files = @{$self->{args}};
my $opt = $self->{opt};
# help these dumb 'shells' that are no shells
if ($files[0] eq 'src/pmc/*.pmc') {
@files = glob $files[0];
}
# make sure that a default.dump will always be created if it doesn't
# already exist; do so by adding default.pmc to list of files for dumping
unless (-e qq{./src/pmc/default.dump}) {
unshift @files, qq{./src/pmc/default.pmc};
}
my $all;
for my $file (@files) {
my ($class, $result) = $self->find_and_parse_pmc($file);
$result->{file} = $file;
$all->{$class} = $result;
}
$all->{default} = $self->read_dump("default.pmc")
if not $all->{default};
my $vt = $self->read_dump("vtable.pmc");
add_defaulted( $all->{default}, $vt );
DO_A_DUMP: foreach my $name (keys %{$all}) {
my $file = $all->{$name}->{file};
my $dumpfile = $file;
$dumpfile =~ s/\.\w+$/.dump/;
my $existing = $self->find_file($dumpfile);
# Am confused about what's intended here. If the .dump file is OLDER
# than the corresponding .pmc file (e.g., if it's some .dump file from
# an earlier run of 'make'), shouldn't it be overwritten so that we
# have an up-to-date .dump file?
if (defined $existing && dump_is_newer($existing)) {
if ($dumpfile =~ /default\.dump$/) {
# don't overwrite default.dump
# skip all preparations for dumping
next DO_A_DUMP;
}
else {
# overwrite anything else
# continue with preparations for dumping
# And what good is assigning the name of the existing dump file to
# that of the newly-to-be-created dumpfile. Wouldn't they have the
# same name in any case? (Or are we dealing with the possibility that
# find_file() will return a file of the same basename but in a
# different directory? Is that a real possibility?)
$dumpfile = $existing;
}
}
$all = $self->gen_parent_list($name, $all);
my $class = gen_super_meths($name, $all, $vt);
my $Dumper = Data::Dumper->new([$class], ['class']);
$Dumper->Indent(1);
my $fh = open_file( ">", $dumpfile );
print $fh $Dumper->Dump;
close $fh;
} # end foreach loop
return 1;
}
=head2 Non-Public Methods
These functions are expressed as methods called on the Parrot::Pmc2c::Utils
object, but only because they make use of data stored in that object. They
are called within the publicly available methods described above and are not
intended to be publicly callable.
=head3 C<find_and_parse_pmc()>
($class, $result) = $self->find_and_parse_pmc($file);
B<Purpose:> Returns the class structure from C<$file> for a F<.dump> file.
B<Arguments:> String holding a file name. The file is one of those provided
by the C<arg> key of the constructor.
B<Return Values:> C<find_and_parse_pmc()> internally calls C<parse_pmc> and directly
returns the latter's list of two return values: a string holding a classname
and a reference to a hash holding the class's attributes.
B<Comments:> Called internally by C<dump_pmc()>. Formerly called
C<dump_1_pmc()>; name was changed because this function doesn't actually do
any 'dumping' in the sense of using Data::Dumper to print the contents of a
variable. Rather, it is a step called by C<dump_pmc()> to prepare for dumping.
=cut
sub find_and_parse_pmc {
my ($self, $file) = @_;
my $opt = $self->{opt};
$file =~ s/\.\w+$/.pmc/;
$file = $self->find_file($file, 1);
my $fh = open_file( "<", $file );
my $contents = do { local $/; <$fh> };
close $fh;
my ($classname, $attributesref) = parse_pmc($contents, $opt);
return ($classname, $attributesref);
}
=head3 C<gen_parent_list()>
$self->gen_parent_list($name, \%all);
B<Purpose:> Generate an ordered list of parent classes to put in the
C<$classes->{class}->{parents}> array, using the given directories
to find parents.
B<Arguments:> List of two arguments:
=over 4
=item *
String holding class name.
=item *
Hash reference holding data structure being built up within C<dump_pmc()>.
=back
B<Return Value:> Reference to hash holding the data structure being built up
within C<dump_pmc()>, suitably modified.
B<Comments:> Called within C<dump_pmc()>.
=cut
sub gen_parent_list {
my $self = shift;
my ($name, $all) = @_;
my @todo = ($name);
my $class = $all->{$name};
while (@todo) {
my $n = shift @todo;
my $sub = $all->{$n};
next if $n eq 'default';
my %parent_hash = %{$sub->{flags}{extends}};
my @keys = keys %parent_hash;
my @parents = sort { $parent_hash{$a} <=> $parent_hash{$b} } @keys;
for my $parent (@parents) {
next if exists $class->{has_parent}{$parent};
$all->{$parent} = $self->read_dump(lc("$parent.pmc"))
if not $all->{$parent};
$class->{has_parent}{$parent} = { %{$all->{$parent}{has_method} }};
push @todo, $parent;
push @{ $class->{parents} }, $parent;
}
}
return $all;
}
=head2 Subroutines
These are auxiliary subroutines called inside the methods described above.
=head3 C<open_file()>
$fh = open_file( "<", $file, $verbose);
B<Purpose:> Utility subroutine.
B<Arguments:> List of scalars: two required, one optional.
=over 4
=item * action
String holding action/direction desired: C<E<lt>> for
reading or C<E<gt>E<gt>> for writing or appending.
=item * filename
String holding name of file to be opened.
=item * verbose
Optional. True value if verbose output is desired. That output will be the
action followed by the filename.
In most cases, the third argument will be C<$self->{opt}{verbose}>.
=back
B<Return Values:> Filehandle to file so opened.
B<Comment:> Called within C<dump_vtable()>, C<read_dump()>, C<find_and_parse_pmc()>,
and C<dump_pmc()>.
=cut
sub open_file {
my $direction = shift;
my $filename = shift;
my $verbose = shift;
my $action =
($direction eq "<") ? "Reading" :
($direction eq ">>") ? "Appending" : "Writing";
print "$action $filename\n" if $verbose;
open my $fh, $direction, $filename or die "$action $filename: $!\n";
return $fh;
}
=head3 C<parse_pmc()>
($classname, $attributesref) = parse_pmc($contents, $opt);
B<Purpose:> Parse PMC code and return the class name and a hash ref of
attributes.
B<Arguments:> List of two arguments:
=over 4
=item *
Code reference holding results of parsing PMC code found in file provided
as argument to C<find_and_parse_pmc()>.
=item *
The hash reference which is the value of the C<opt> key provided to constructor.
=back
B<Return Values:> List of two elements:
=over 4
=item *
String holding a classname.
=item *
Reference to a hash of the class's attributes. Keys:
pre
flags
methods
post
class
has_method
=back
B<Comments:> Called internally by C<find_and_parse_pmc()>.
=cut
sub parse_pmc {
my ($code, $opt) = @_;
my ($pre, $classname, $flags_ref) = parse_flags(\$code);
my ($classblock, $post) = extract_balanced($code);
my $lineno = 1 + count_newlines($pre);
$classblock = substr($classblock, 1,-1); # trim out the { }
my (@methods, %meth_hash, $class_init);
my $signature_re = qr{
^
(?: #blank spaces and comments and spurious semicolons
[;\n\s]*
(?:/\*.*?\*/)? # C-like comments
)*
(METHOD\s+)? #method flag
(\w+\**) #type
\s+
(\w+) #method name
\s*
\( ([^\(]*) \) #parameters
\s*
((?::(\w+)\s*)*) #method attrs
}sx;
while ($classblock =~ s/($signature_re)//) {
$lineno += count_newlines($1);
my ($flag, $type, $methodname, $parameters) = ($2,$3,$4,$5);
my $attrs = parse_method_attrs($6);
my ($methodblock, $rema) = extract_balanced($classblock);
$methodblock = "" if $opt->{nobody};
if ($methodname eq 'class_init') {
$class_init = {
meth => $methodname,
body => $methodblock,
line => $lineno,
type => $type,
parameters => $parameters,
loc => "vtable",
attrs => $attrs,
};
}
else {
# name => method idx mapping
$meth_hash{$methodname} = scalar @methods;
my @mmds = ($methodblock =~ /MMD_(\w+):/g);
push @methods,
{
meth => $methodname,
body => $methodblock,
line => $lineno,
type => $type,
parameters => $parameters,
loc => $flag ? "nci" : "vtable",
mmds => [ @mmds ],
attrs => $attrs,
};
}
$classblock = $rema;
$lineno += count_newlines($methodblock);
}
if ($class_init) {
$meth_hash{'class_init'} = scalar @methods;
push @methods, $class_init;
}
return $classname, {
pre => $pre,
flags => $flags_ref,
methods => [EMAIL PROTECTED],
post => $post,
class => $classname,
has_method => \%meth_hash,
};
}
=head3 C<parse_flags()>
($pre, $classname, $flags_ref) = parse_flags(\$code);
B<Purpose:> Extract a class signature from the code ref.
B<Argument:> De-reference the code ref which was the first argument
provided to C<parse_pmc()>.
B<Return Values:> List of three elements:
=over 4
=item *
the code found before the class signature;
=item *
the name of the class; and
=item *
a hash ref containing the flags associated with the class (such as
C<extends> and C<does>).
=back
B<Comments:> Called internally by C<parse_pmc()>.
=cut
sub parse_flags {
my $c = shift;
$$c =~ s/^(.*?^\s*)pmclass ([\w]*)//ms;
my ($pre, $classname) = ($1, $2);
# flags that have values passed with them
my %has_value = map { $_ => 1 } qw(does extends group lib hll maps);
my (%flags, $parent_nr);
# look through the pmc declaration header for flags such as noinit
while ($$c =~ s/^\s*(\w+)//s) {
my $flag = $1;
if ($has_value{$flag}) {
$$c =~ s/^\s+(\w+)//s
or die "Parser error: no value for '$flag'";
$flags{$flag}{$1} =
$flag eq 'extends' ? ++$parent_nr : 1;
}
else {
$flags{$flag} = 1;
}
}
# setup some defaults
if ($classname ne 'default') {
$flags{extends}{default} = 1 unless $flags{extends};
$flags{does}{scalar} = 1 unless $flags{does};
}
return $pre, $classname, \%flags;
}
=head3 C<extract_balanced()>
($classblock, $post) = extract_balanced($code);
B<Purpose:> Remove a balanced C<{}> construct from the beginning of C<$code>.
Return it and the remaining code.
B<Argument:> The code ref which was the first argument provided to C<parse_pmc()>.
B<Return Values:> List of two elements:
=over 4
=item *
String beginning with C<{> and ending with C<}>. In between is found C code
where the comments hold strings of Perl comments written in POD.
=item *
String holding the balance of the code. Same style as first element, but
without the braces.
=back
B<Comments:> Called twice within C<parse_pmc()>. Will die with error message
C<Badly balanced> if not balanced.
=cut
sub extract_balanced {
my $code = shift;
my $balance = 0;
$code =~ s/^\s+//;
# create a copy and remove strings and comments so that
# unbalanced {} can be used in them in PMCs, being careful to
# preserve string length.
local $_ = $code;
s[
( ' (?: \\. | [^'] )* ' # remove ' strings
| " (?: \\. | [^"] )* " # remove " strings
| /\* .*? \*/ ) # remove C comments
]
[ "-" x length $1 ]sexg;
/^\{/ or die "bad block open: ", substr($code,0,10), "...";
while (/ (\{) | (\}) /gx) {
if($1) {
$balance++;
} else { # $2
$balance--;
return substr($code, 0, pos, ""), $code
if not $balance;
}
}
die "Badly balanced" if $balance;
return;
}
=head3 C<parse_method_attrs()>
$attrs = parse_method_attrs($method_attributes);
B<Purpose:> Parse a list of method attributes and return a hash ref of them.
B<Arguments:> String captured from regular expression.
B<Return Values:> Reference to hash of attribute values.
B<Comments:> Called within C<parse_pmc()>.
=cut
sub parse_method_attrs {
my $flags = shift;
my %result;
++$result{$1} while $flags =~ /:(\w+)/g;
return \%result;
}
=head3 C<add_defaulted()>
add_defaulted( $all->{default}, $vt );
B<Purpose:> Add methods to the class structure for each method found in the
vtable. This is used to determine all of the C<default> methods
from the F<vtable.dump>.
B<Arguments:> List of two arguments:
=over 4
=item *
A reference to a hash holding a data structure being built up within
C<dump_pmc()>.
=item *
The result of a call of C<read_dump()> on F<vtable.pmc>.
=back
B<Return Values:> C<undef> upon success. I intend to change this to a more
Perlish true value.
B<Comments:> Called within C<dump_pmc()>.
=cut
sub add_defaulted {
my ( $class, $vt ) = @_;
foreach my $e ( @{ $vt->{methods} } ) {
my $meth = $e->{meth};
$class->{super}{$meth} = 'default';
}
return;
}
=head3 C<dump_is_newer()>
dump_is_newer($existing);
B<Purpose:> Determines whether the dump of a file is newer than the PMC file.
(If it's not, then the PMC file has changed and the dump has not been updated.)
B<Arguments:> String holding filename.
B<Return Values:> Returns true if timestamp of existing is more recent than
that of PMC.
B<Comments:> Called within C<find_and_parse_pmc()>.
=cut
sub dump_is_newer {
my $dumpfile = shift;
# Extract name of .pmc file corresponding to .dump file
my $pmc = $dumpfile;
$pmc =~ s/\.\w+$/.pmc/;
my $pmc_dt = 0;
my $dump_dt = 0;
$pmc_dt = (stat $pmc)[9];
$dump_dt = (stat $dumpfile)[9];
return $dump_dt > $pmc_dt;
}
=head3 C<gen_super_meths()>
$class = gen_super_meths($name, $all, $vt);
B<Purpose:> Generate a list of inherited methods for C<$name> by searching the
inheritance tree. The method list is found in C<$vt>.
B<Arguments:> List of three elements:
=over 4
=item *
String holding name of class being dumped.
=item *
Reference to the hash holding the data structure being built up within
C<dump_pmc()>.
=item *
The result of a call of C<read_dump()> on F<vtable.pmc>.
=back
B<Return Value:> Hash reference representing the class being dumped.
B<Comments:> Called within C<dump_pmc()>.
=cut
sub gen_super_meths {
my ($name, $all, $vt) = @_;
my $class = $all->{$name};
# look through all meths in class and locate the nearest parent
foreach my $entry (@{ $vt->{methods} } ) {
my $meth = $entry->{meth};
next if exists $class->{super}{$meth};
foreach my $pname (@{ $class->{parents} } ) {
if (exists ($class->{has_parent}{$pname}{$meth} )) {
$class->{super}{$meth} = $pname;
my $n = $class->{has_parent}{$pname}{$meth};
$class->{super_attrs}{$meth} =
$all->{$pname}{methods}[$n]{attrs};
if (exists $class->{has_method}{$meth}) {
$class = inherit_attrs($class, $meth);
}
my $super_mmd = $all->{$pname}{methods}[$n]{mmds};
if ($super_mmd && scalar @{ $super_mmd }) {
push @{ $class->{super_mmd} }, {
$pname => $super_mmd,
'meth' => $meth
};
}
last;
}
}
unless (exists $class->{super}{$meth}) {
# XXX this is a quick hack to get the inheritance
# ParrotClass isa delegate
#
# delegate has everything autogenerated, so these
# methods aren't seen and not inherited properly
#
# the correct way would be to look at
# $class->implements but when dumping there isn't
# a $class object
$class->{super}{$meth} =
$class->{class} eq 'ParrotObject' ||
$class->{class} eq 'ParrotClass' ?
'delegate' :
'default';
}
}
return $class;
}
=head3 C<inherit_attrs()>
$class = inherit_attrs($class, $meth);
B<Purpose:> Modify $attrs to inherit attrs from $super_attrs as appropriate.
B<Arguments:> List of two arguments:
=over 4
=item *
Reference to hash holding the data structure being built up within
C<dump_pmc()>.
=item *
Method name.
=back
B<Return Values:> Reference to hash holding the data structure being built up
within C<dump_pmc()>.
B<Comments:> Called within C<gen_super_meths()>.
=cut
sub inherit_attrs {
my ($class, $meth) = @_;
my $super_attrs = $class->{methods}[$class->{has_method}{$meth}]->{attrs};
my $attrs = $class->{super_attrs}{$meth};
if (
($super_attrs->{read} or $super_attrs->{write})
and
not ($attrs->{read} or $attrs->{write})
) {
$attrs->{read} = $super_attrs->{read}
if exists $super_attrs->{read};
$attrs->{write} = $super_attrs->{write}
if exists $super_attrs->{write};
}
return $class;
}
=head1 AUTHOR
Leopold Toetsch wrote F<pmc2c.pl>. It was cleaned up by Matt Diephouse.
James E Keenan extracted the subroutines into F<lib/Parrot/Pmc2c/Utils.pm> and
wrote the accompanying test suite.
=head1 SEE ALSO
F<tools/build/pmc2c.pl>, Parrot::Pmc2c, Parrot::Pmc2c::Library.
=cut
1;
04-dump_pmc.t
Description: Troff document
