libkiokudb-perl 0.57-1 / usr / share / perl5 / KiokuDB / TypeMap / Entry / Closure.pm

package KiokuDB::TypeMap::Entry::Closure;
BEGIN {
  $KiokuDB::TypeMap::Entry::Closure::AUTHORITY = 'cpan:NUFFIN';
}
$KiokuDB::TypeMap::Entry::Closure::VERSION = '0.57';
use Moose;

use Carp qw(croak);
use Scalar::Util qw(refaddr);
use PadWalker 1.9;
use Class::Load ();

no warnings 'recursion';

use namespace::clean -except => 'meta';

with qw(KiokuDB::TypeMap::Entry::Std);

sub compile_collapse_body {
    my $self = shift;

    require B;
    require B::Deparse;

    return sub {
        my ( $collapser, %args ) = @_;

        my $sub = $args{object};

        my ( $pkg, $name ) = Class::MOP::get_code_info($sub);

        my %data;

        # FIXME make this customizable on a per sub and per typemap level
        if ( $name eq '__ANON__' ) {
            my $pad = PadWalker::closed_over($sub);

            if ( keys %$pad ) {
                my $collapsed_pad = $collapser->visit($pad);

                $data{pad} = $collapsed_pad;

                my $buffer = $collapser->_buffer;
                my $pad_entry_data = blessed $collapsed_pad ? $buffer->id_to_entry( $collapsed_pad->id )->data : $collapsed_pad;

                $buffer->first_class->insert(map { $_->id } values %$pad_entry_data ); # maybe only if entry($_->id)->object's refcount is > 1 (only shared closure vars) ?
            }

            # FIXME find all GVs in the optree and insert refs to them?
            # i suppose they should be handled like named...
            $data{body} = $self->_deparse($sub);
        } else {
            ( my $pkg_file = "${pkg}.pm" ) =~ s{::}{/}g;

            my $file;

            if ( my $meta = Class::MOP::get_metaclass_by_name($pkg) ) {
                if ( my $method = $meta->get_method($name) ) {
                    if ( refaddr($method->body) == refaddr($sub)
                            and
                        $method->isa("Class::MOP::Method::Generated")
                            and
                        $method->can("definition_context")
                    ) {
                        $file = $method->definition_context->{file};
                    }
                }
            }

            unless ( defined $file ) {
                my $cv = B::svref_2object($sub);
                $file = $cv->FILE unless $cv->XSUB; # Can't really tell who called newXS or even bootstrap, so we assume the package .pm did
            }

            my $inc_key;

            if ( defined $file ) {
                my %rev_inc = reverse %INC;
                $inc_key = $rev_inc{$file};
                $inc_key = $file unless defined $inc_key;
            }

            if ( defined($inc_key) and $pkg_file ne $inc_key ) {
                $data{file} = $inc_key;
            }

            @data{qw(package name)} = ( $pkg, $name );
        }

        return $collapser->make_entry(
            %args,
            object => $sub,
            data   => \%data,
        );
    };
}

sub _deparse {
    my ( $self, $cv ) = @_;

    B::Deparse->new->coderef2text($cv);
}

sub compile_expand {
    my $self = shift;

    return sub {
        my ( $linker, $entry ) = @_;

        my $data = $entry->data;

        if ( exists $data->{body} ) {
            my ( $body, $pad ) = @{ $data }{qw(body pad)};

            my $inflated_pad;
            $linker->inflate_data( $pad, \$inflated_pad );

            my $sub = $self->_eval_body( $linker, $body, $inflated_pad );

            $linker->register_object( $entry => $sub );

            return $sub;
        } else {
            my $fq = join("::", @{ $data }{qw(package name)});
            my $glob = do { no strict 'refs'; *$fq };

            unless ( defined(*{$glob}{CODE}) ) {
                if ( defined(my $file = $data->{file}) ) {
                    require $file unless exists $INC{$file};
                } else {
                    Class::Load::load_class($data->{package});
                }

                unless ( defined(*{$glob}{CODE}) ) {
                    croak "The subroutine &$data->{name} is no longer defined, but is referred to in the database";
                }
            }

            my $sub = *{$glob}{CODE};

            $linker->register_object( $entry => $sub );

            return $sub;
        }
    };
}

sub compile_refresh {
    my $self = shift;

    return sub {
        croak "refreshing of closures is not yet supported";
    };
}

sub _eval_body {
    my ( $self, $linker, $body, $pad ) = @_;

    my ( $sub, $e ) = do {
        local $@;

        if ( my @vars = keys %$pad ) {
            my $vars = join ", ", @vars;

            # FIXME Parse::Perl
            my $sub = eval "
                my ( $vars );
                sub $body;
            ";

            my $e = $@;

            $linker->queue_finalizer(sub {
                PadWalker::set_closed_over($sub, $pad);
            }) if $sub;

            ( $sub, $e );
        } else {
            eval "sub $body", $@;
        }
    };

    die $e unless $sub;

    return $sub;
}


__PACKAGE__->meta->make_immutable;

__PACKAGE__

__END__

=pod

=encoding UTF-8

=head1 NAME

KiokuDB::TypeMap::Entry::Closure

=head1 VERSION

version 0.57

=head1 AUTHOR

Yuval Kogman <nothingmuch@woobling.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014 by Yuval Kogman, Infinity Interactive.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut