File Coverage

blib/lib/Devel/PerlySense/CallTree/Graph.pm

Criterion	Covered	Total	%
statement	77	80	96.2
branch	1	2	50.0
condition			n/a
subroutine	21	22	95.4
pod	0	6	0.0
total	99	110	90.0

=head1 NAME

Devel::PerlySense::CallTree::Graph - A GraphViz graph of the CallTree

=head1 DESCRIPTION


=cut

package Devel::PerlySense::CallTree::Graph;
$Devel::PerlySense::CallTree::Graph::VERSION = '0.0217';
use strict;
use warnings;
use utf8;



use Moo;
use Path::Tiny;
use Digest::SHA qw/ sha256_hex /;

use Devel::PerlySense::CallTree;
use Devel::PerlySense::CallTree::Caller;



has call_tree => ( is => "ro", required => 1 );

has output_format => ( is => "lazy" );
sub _build_output_format { "png" }

has output_dir => ( is => "lazy" );
sub _build_output_dir { "." }
around output_dir => sub {
    my $orig = shift;
    my $self = shift;
    my $dir = $self->$orig(@_);

    (-e $dir) or $dir->mkpath();
    (-d $dir) or die("Can not create directory ($dir)\n");

    return $dir;
};

has base_file => ( is => "lazy" );
sub _build_base_file {
    my $self = shift;
    return sha256_hex( $self->edge_declarations_text );
}

has dot_file => ( is => "lazy" );
sub _build_dot_file {
    my $self = shift;
    my $file = path($self->output_dir, $self->base_file . ".dot")->absolute;
    return $file;
}

has output_file => ( is => "lazy" );
sub _build_output_file {
    my $self = shift;
    path($self->output_dir, $self->base_file . "." . $self->output_format)->absolute;
}

has edge_declarations_text => ( is => "lazy" );
sub _build_edge_declarations_text {
    my $self = shift;
    my $called_by_caller = $self->call_tree->method_called_by_caller;
    my $edge_declarations = join(
        "\n",
        map {
            my $callers = $called_by_caller->{ $_ };
            my @callers = sort keys %$callers;
            my $target = Devel::PerlySense::CallTree::Caller->new({
                caller => $_,
            });
            join(
                "\n",
                map {
                    my $method_caller  = $_;
                    my $caller = Devel::PerlySense::CallTree::Caller->new({
                        caller => $method_caller,
                    });
                    "    " . $caller->id . " -> " . $target->id;
                }
                @callers
            );
        }
        sort keys %$called_by_caller
    );
    return $edge_declarations;
}

has cluster_declarations_text => ( is => "lazy" );
sub _build_cluster_declarations_text {
    my $self = shift;
    my $package_callers = $self->call_tree->package_callers;
    my $cluster_declarations = join(
        "\n",
        map {
            my $package = $_;
            my $callers = $package_callers->{ $package };
            my $node_declarations = join(
                "\n",
                map { "    " . $self->node_declaration($_) }
                @$callers
            );

            my $package_id = $self->to_id(package => $package);
            qq|
        subgraph cluster_${package_id} {
                label = "$package";
$node_declarations
        }
|;
        }
        sort keys %$package_callers
    );
    return $cluster_declarations;
}

has dot_source_template => ( is => "lazy" );
sub _build_dot_source_template {
    my $self = shift;
    my $source = qq|
digraph d {
        overlap  = false
        ranksep  = 0.3; nodesep = 0.1;
        rankdir  = TB;
        fontname = "Verdana";
        labelloc = "t";

        // splines=ortho

        graph [
                fontname = "Verdana",
                fontsize = 10,
                fontcolor = "#2980b9",
                style = "rounded",
                color="#cccccc",
        ];

        node [
                width    = 0.1,
                height   = 0.2,
                fontname = "Verdana",
                fontsize = 8,
                shape    = "none",
        ];
        edge [
                arrowsize = 0.4,
                fontname  = "Helvetica",
                fontsize  = 9,
        ];


%s


%s

}

|;
}

sub create_graph {
    my $self = shift;
    my $dot_file = $self->dot_file;
    $self->write_dot_file( $dot_file );
    $self->run_dot( $dot_file, $self->output_file );
}

sub node_declaration {
    my $self = shift;
    my ($caller) = @_;
    return sprintf(
        qq{    %s [ label="%s" ];},
        $caller->id,
        $caller->method,
    );
}

sub to_id {
    my $self = shift;
    my ($prefix, $name) = @_;
    $name =~ s/\W+/_/gsm;
    return join("_", $prefix, lc($name));
}

sub to_caller {
    my $self = shift;
    my ($caller) = @_;
    return Devel::PerlySense::CallTree::Caller->new({ caller => $caller });
}

sub write_dot_file {
    my $self = shift;
    my ($filename) = @_;
    my $source = sprintf(
        $self->dot_source_template,
        $self->cluster_declarations_text(),
        $self->edge_declarations_text(),
    );
    path($filename)->spew($source);
}

sub run_dot {
    my $self = shift;
    my ($dot_file, $output_file) = @_;
    my $format = $self->output_format;
    my $command = qq|dot -T$format -o"$output_file" "$dot_file" 2>&1|;
    my $error = qx($command);
    $error and die("Could not run 'dot':\n$!\n$error \n");
}

1;




__END__

=encoding utf8

=head1 AUTHOR

Johan Lindstrom, C<< <[e-mail]> >>

=head1 BUGS

Please report any bugs or feature requests to
C<[e-mail]>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Devel-PerlySense>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2005 Johan Lindstrom, All Rights Reserved.

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

=cut