File Coverage

blib/lib/Devel/Decouple.pm

Criterion	Covered	Total	%
statement	135	135	100.0
branch	25	28	89.2
condition	15	19	78.9
subroutine	34	34	100.0
pod	15	15	100.0
total	224	231	96.9

# $Id$
package Devel::Decouple;

use strict;
use warnings;
use Carp;
use version; our $VERSION = qv(0.0.3);

use base 'Exporter';
our @EXPORT = qw{ from function functions as default_sub preserved };

use Class::Inspector;
use PPI::Document;
use PPI::Find;
use Monkey::Patch   qw{ patch_package };
use List::MoreUtils qw{ uniq };

### PUBLIC METHODS: ########################

sub new {
    my $class = shift;
    return bless {}, $class;
}

sub decouple {
    my $self    = shift;
    my $module  = shift || croak q{You must supply a module name to the 'decouple' method};
    my @args    = @_;
    my $modules = shift @args if ref $args[0] eq 'ARRAY';

    # build the params hash
    my %params;
    $params{_MODULE_}   = $module;
    $params{_DOCUMENT_} = Class::Inspector->resolved_filename( $module )
                            or croak "could not resolve the canonical name of $module";
    $params{_MODULES_}  = $modules || '_ALL_';
    $params{_CODE_}     = { @args };
    $params{_CODE_}{_DEFAULT_} ||= sub { return };

    $self->{$_} = $params{$_} for keys %params;

    $self->_build;

    return $self;
}

sub module {
    my $self = shift;
    return $self->{_MODULE_};
}

sub document {
    my $self = shift;
    return $self->{_DOCUMENT_};
}

sub modules {
    my $self = shift;
    return exists $self->{_MODULES_}
        ? @{ $self->{_MODULES_} }
        : undef;
}

sub called_imports{
    my $self = shift;
    return exists $self->{_CALLED_IMPORTS_}
        ? @{ $self->{_CALLED_IMPORTS_} }
        : undef;
}

sub all_functions {
    my $self = shift;

    return $self->module
        ? @{Class::Inspector->functions( $self->module )}
        : undef;
}

sub revert{
    my $self      = shift;
    my @functions = @_;

    map { $self->{_PATCHES_}{$_} = undef } @functions;

    return $self;
}

sub report{
    my $self = shift;

    return $self->document
        ? $self->_build_report
        : croak qq{ 'report' called on uninitialized object };
}

### EXPORTS FOR SYNTACTIC SUGAR: ###########

sub from(\@;%) {
    return @_;
}

sub function($) {
    return shift;
}

sub functions(\@$;%) {
    my $functions = shift;
    my $code      = shift;
    my %args      = @_;

    my %map = map { $_ => $code } @{$functions};

    return %map, %args;
}

sub as(&) {
    return shift;
}

sub default_sub() {
    return '_DEFAULT_';
}

sub preserved() {
    return '_PRESERVED_';
}

### PRIVATE METHODS: #######################

sub _build {
    my $self   = shift;

    $self->_build_imports();
    $self->_set_code_substitutions();
}

sub _build_report {
    my $self    = shift;
    my $spacing = 20;
    my $indent  = 4;

    # format a simplistic report...
    my $report = "\nFunction-import usage statistics for ".($self->module||$self->document).":\n";

    for my $module ( $self->modules ){
        $report .= " "x($indent)."$module\n";
        map { $report .= " "x(2*$indent)."$_"." "x($spacing-length($_))."calls: ".
              $self->{_CALLED_IMPORT_STATS_}{$module}{$_}{ _NUMBER_OF_CALLS_ }."\tlines: ".
              (join ',', @{$self->{_CALLED_IMPORT_STATS_}{$module}{$_}{_LINE_NUMBERS_}}).".\n" }
            sort keys %{$self->{_CALLED_IMPORT_STATS_}{$module}};
    }

    return $report;
}

sub _build_imports {
    my $self = shift;

    my ($CallFinder,$Document) = $self->_create_call_finder;
    my @found = $CallFinder->in( $Document );

    for my $module ( $self->_get_modules ){
        no strict 'refs';
        for my $function ( @{$module.'::EXPORT'}, @{$module.'::EXPORT_OK'} ){
            for my $token ( @found ){
                if ( $token eq $function ){
                    $self->{_CALLED_IMPORT_STATS_}{$module}{$function}{_NUMBER_OF_CALLS_}++;
                    push @{$self->{_CALLED_IMPORT_STATS_}{$module}{$function}{_LINE_NUMBERS_}}, $token->line_number;
                }
            }
        }
    }

    $self->{ _MODULES_ } = [ keys %{ $self->{_CALLED_IMPORT_STATS_} }];
    for my $module ( $self->modules ){
        push @{$self->{_CALLED_IMPORTS_}}, $_ for keys %{$self->{_CALLED_IMPORT_STATS_}{$module}};
    }

    return $self;
}

sub _get_modules {
    my $self    = shift;

    $self->{_MODULES_} eq '_ALL_'
        ? return map { my $module = $_; $module =~ s{\.pm}{}; $module }
                    map { my $module = $_; $module =~ s{[\/\\]}{::}g; $module }
                        grep { m{\.pm$} } keys %INC
        : return @{ $self->{_MODULES_} };
}

sub _create_call_finder {
    my $self = shift;

    my $Document = PPI::Document->new( $self->document );
    my $Finder   = PPI::Find->new(
                        sub {
                            $_[1]->isa( 'PPI::Element' ) | $_[1]->isa( 'PPI::Token' )
                                ? $_[0]->isa( 'PPI::Token::Word' )
                                    ? return 1
                                    : return 0
                                : return;
                        });

    return $Finder, $Document;
}

sub _set_code_substitutions{
    my $self = shift;

    for my $function ( uniq $self->called_imports, keys %{$self->{_CODE_}} ){
        next if ( (defined $self->{_CODE_}{$function} && ref $self->{_CODE_}{$function} ne 'CODE')
                    || $function eq '_DEFAULT_');

        if ( ref $self->{_CODE_}{$function} eq 'CODE' || ref $self->{_CODE_}{_DEFAULT_} eq 'CODE' ){
            $self->{_PATCHES_}{$function} = patch_package(
                    $self->module,                                              # module
                    $function,                                                  # function-name
                    ref $self->{_CODE_}{$function} eq 'CODE'                    # code
                        ? $self->{_CODE_}{$function}
                        : $self->{_CODE_}{_DEFAULT_}
                    ) or croak "couldn't install the code stub for '$function'";
        }
    }
}

1; # return true
__END__