view release on metacpan or  search on metacpan

lib/MooseX/Compile/Compiler.pm  view on Meta::CPAN

#!/usr/bin/perl

package MooseX::Compile::Compiler;
use base qw(MooseX::Compile::Base);

use strict;
use warnings;

use Data::Dump qw(dump);
use Data::Visitor::Callback;
use Storable;
use B;
use B::Deparse;
use PadWalker;
use Class::Inspector;

our %compiled_classes;

use constant DEBUG => MooseX::Compile::Base::DEBUG();

# FIXME make this Moose based eventually
sub new {
    my ( $class, %args ) = @_;
    bless \%args, $class;
}

sub compile_class {
    my ( $self, %args ) = @_;
    my $class = $args{class};

    ( my $short_name = "$class.pm" ) =~ s{::}{/}g;
    $args{short_name} = $short_name;

    unless ( defined $args{file} ) {
        $args{file} = $INC{$short_name};
    }

    unless ( defined $args{pmc_file} ) {
        $args{pmc_file} = "$args{file}c";
    }

    if ( $compiled_classes{$class}++ ) {
        warn "already compiled class '$class'\n" if DEBUG;
        return;
    }

    my $t = times;

    $self->cache_meta(%args);
    $self->write_pmc_file(%args);

    warn "compilation of .pmc and .mopc for class '$class' took " . ( times - $t ) . "s\n" if DEBUG;
}

# FIXME these should really be methods, I suppose

sub sym ($$;@) {
    my ( $sym, $type, @args ) = @_;
    bless { @args, name => $sym }, "MooseX::Compile::mangled::$type";
}

sub package_name ($;$) {
    my ( $code, $cv ) = @_;
    $cv ||= B::svref_2object($code);
    local $@;
    return eval { $cv->GV->STASH->NAME };
}

sub code_name ($;$) {
    my ( $code, $cv ) = @_;
    $cv ||= B::svref_2object($code);
    local $@;
    return eval { join("::", package_name($code, $cv), $cv->GV->NAME) };
}

lib/MooseX/Compile/Compiler.pm  view on Meta::CPAN

        my $method = "compile_${category}_code_symbols";
        push @ret, $self->$method( %args, symbols => delete($symbols->{$category}) );
    }

    @ret;
}

sub compile_file_code_symbols {
    # this is already taken care of by the inclusion of the whole .pm after the preamble
    return;
}

sub compile_meta_code_symbols {
    # we fake this one 
    return;
}

sub compile_moose_exports_code_symbols {
    # not yet implemented
    return;
}

sub compile_moose_sugar_code_symbols {
    my ( $self, %args ) = @_;
    return map {
        my $name = $_->{name};
        my $proto = prototype($_->{body});
        $proto = $proto ? " ($proto)" : "";
        "*$name = Sub::Name::subname('Moose::$name', sub$proto { });";
    } @{ $args{symbols} || [] };
}


sub compile_generated_code_symbols {
    my ( $self, %args ) = @_;
    map { sprintf "*%s = %s;", $_->name => $self->compile_method(%args, method => $_) } map { $_->{meta} } @{ $args{symbols} };
}

sub compile_aliased_code_symbols {
    return;
}

sub compile_unknown_method_code_symbols {
    return;
}

sub compile_unknown_function_code_symbols {
    return;
}

sub compile_method {
    my ( $self, %args ) = @_;
    my ( $class, $method ) = @args{qw(class method)};

    my $d = B::Deparse->new;

    my $body = $method->body;

    my $body_str = $d->coderef2text($body);

    my $closure_vars = PadWalker::closed_over($body);

    my @env;

    if ( my $constraints = delete $closure_vars->{'@type_constraints'} ) {
        my @constraint_code = map {
            my $name = $_->name;

            defined $name
                ? "Moose::Util::TypeConstraints::find_type_constraint(". dump($name) .")"
                : "die 'missing constraint'"
        } @$constraints;
        
        push @env, "CORE::require Moose::Util::TypeConstraints::OptimizedConstraints", join("\n    ", 'my @type_constraints = (', map { "$_," } @constraint_code ) . "\n)",
    }
    
    push @env, map {
        my $ref = $closure_vars->{$_};

        my $scalar = ref($ref) eq 'SCALAR' || ref($ref) eq 'REF';

        "my $_ = " . ( $scalar
            ? $self->_value_to_perl($$ref)
            : "(" . join(", ", map { $self->_value_to_perl($_) } @$ref ) . ")" )
    } keys %$closure_vars;

    my $name = code_name($body);
    my $quoted_name = dump($name);

    if ( @env ) {
        my $env = join(";\n\n", @env);
        $env =~ s/^/    /gm;
        return "Sub::Name::subname( $quoted_name, do {\n$env;\n\n\nsub $body_str\n})";
    } else {
        return "Sub::Name::subname( $quoted_name, sub $body_str )";
    }
}

sub _value_to_perl {
    my ( $self, $value ) = @_;

    ( (ref($value)||'') eq 'CODE'
        ? $self->_subref_to_perl($value)
        : Data::Dump::dump($value) ) 
}

sub _subref_to_perl {
    my ( $self, $subref ) = @_;

    my %rev_inc = reverse %INC;

    if ( ( my $name = code_name($subref) ) !~ /__ANON__$/ ) {
        if ( -f ( my $file = B::svref_2object($subref)->FILE ) ) {
            return "do { require " . dump($rev_inc{$file}) . "; \\&$name }";
        } else {
            return '\&' . $name;
        }
    } else {
        "sub " . B::Deparse->new->coderef2text($subref);
    }
}