File Coverage

blib/lib/Makefile/GraphViz.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Makefile::GraphViz;

use strict;
use warnings;
use vars qw($VERSION);

#use Smart::Comments;
use GraphViz;
use base 'Makefile::Parser';

$VERSION = '0.20';

$Makefile::Parser::Strict = 0;

our $IDCounter = 0;

my %VirNodeStyle =
(
    shape => 'plaintext',
);

my %NormalNodeStyle =
(
    shape => 'box',
    style => 'filled',
    fillcolor => '#f5f694',
);

my %EdgeStyle =
(
    color => 'red',
);

my %CmdStyle =
(
    shape => 'ellipse',
    style => 'filled',
    fillcolor => '#c7f77c',
);

my %InitArgs = (
    layout => 'dot',
    ratio => 'auto',
    node => \%NormalNodeStyle,
    edge => \%EdgeStyle,
);

our %Nodes;

sub _gen_id () {
    return ++$IDCounter;
}

sub _trim_path ($) {
    my $s = shift;
    $s =~ s/.+(.{5}[\\\/].*)$/...$1/o;
    $s =~ s/\\/\\\\/g;
    return $s;
}

sub _trim_cmd ($) {
    my $s = shift;
    $s =~ s/((?:\S+\s+){2})\S.*/$1.../o;
    $s =~ s/\\/\\\\/g;
    return $s;
}

sub _find ($@) {
    my $elem = shift;
    foreach (@_) {
        return 1 if $elem eq $_;
    }
    return undef;
}

sub plot ($$@) {
    my $self = shift;
    my $root_name = shift;
    my %opts = @_;
    #warn "@_\n";

    # process the ``gv'' option:
    my $gv = $opts{gv};

    # process the ``vir_nodes'' option:
    my $val = $opts{vir_nodes};
    my @vir_nodes = @$val if $val and ref $val;
    my %vir_nodes;
    map { $vir_nodes{$_} = 1 } @vir_nodes;

    # process the ``normal_nodes'' option:
    $val = $opts{normal_nodes};
    my @normal_nodes = @$val if $val and ref $val;
    my %normal_nodes;
    map { $normal_nodes{$_} = 1 } @normal_nodes;

    # process the ``init_args'' option:
    $val = $opts{init_args};
    my %init_args = ($val and ref $val) ? %$val : %InitArgs;

    # process the ``edge_style'' option:
    $val = $opts{edge_style};
    my %edge_style = ($val and ref $val) ? %$val : %EdgeStyle;
    $init_args{edge} = \%edge_style;

    # process the ``normal_node_style'' option:
    $val = $opts{normal_node_style};
    my %normal_node_style = ($val and ref $val) ? %$val : %NormalNodeStyle;
    $init_args{node} = \%normal_node_style;

    # process the ``vir_node_style'' option:
    $val = $opts{vir_node_style};
    my %vir_node_style = ($val and ref $val) ? %$val : %VirNodeStyle;

    # process the ``cmd_style'' option:
    $val = $opts{cmd_style};
    my %cmd_style = ($val and ref $val) ? %$val : %CmdStyle;

    # process the ``trim_mode'' option:
    my $trim_mode = $opts{trim_mode};
    #warn "TRIM MODE: $trim_mode\n";

    # process the ``end_with'' option:
    $val = $opts{end_with};
    my @end_with = ($val and ref $val) ? @$val : ();

    # process the ``exclude'' option:
    $val = $opts{exclude};
    my @exclude = ($val and ref $val) ? @$val : ();

    return $gv if _find($root_name, @exclude);

    if (!$gv) {
        $gv = GraphViz->new(%init_args);
        %Nodes = ();
    }

    my $is_virtual = 0;
    if ($Nodes{$root_name}) {
        return $gv;
    }
    $Nodes{$root_name} = 1;
    #warn "GraphViz: $gv\n";

    my @roots = ($root_name and ref $root_name) ?
        $root_name : ($self->target($root_name));

    my $short_name = _trim_path($root_name);
    if ($normal_nodes{$root_name}) {
        $is_virtual = 0;
    } elsif ($vir_nodes{$root_name} or @roots and !$roots[0]->commands) {
        $is_virtual = 1;
    }

    if (!@roots or _find($root_name, @end_with)) {
        $gv->add_node(
            $root_name,
            label => $short_name,
            $is_virtual ? %vir_node_style : ()
        );
        return $gv;
    }
    #my $short_name = $root_name;

    my $i = 0;
    for my $root (@roots) {
        #warn $i, "???\n";
        ### $root_name
        ### $root
        #$short_name =~ s/\\/\//g;
        #warn $short_name, "\n";
        #warn $short_name, "!!!!!!!!!!!!!!!!\n";
        $gv->add_node(
            $root_name,
            label => $short_name,
            $is_virtual ? %vir_node_style : ()
        );

        #warn $gv;
        my $lower_node;
        my @cmds = $root->commands;
        if (!$trim_mode and @cmds) {
            $lower_node = _gen_id();
            my $cmds = join("\n", map { _trim_cmd($_); } @cmds);
            $gv->add_node($lower_node, label => $cmds, %cmd_style);
            $gv->add_edge(
                $lower_node => $root_name,
                $is_virtual ? (style => 'dashed') : ()
            );
        } else {
            $lower_node = $root_name;
        }

        my @prereqs = $root->prereqs;
        foreach (@prereqs) {
            #warn "$_\n";
            next if _find($_, @exclude);
            $gv->add_edge(
                $_ => $lower_node,
                $is_virtual ? (style => 'dashed') : ());
            #warn "$_ ++++++++++++++++++++\n";
            $self->plot($_, gv => $gv, @_);
        }
        #warn "END\n";
        #warn "GraphViz: $gv\n";
    } continue { $i++ }
    return $gv;
}

sub plot_all ($) {
    my $self = shift;
    my $gv = GraphViz->new(%InitArgs);
    %Nodes = ();
    for my $target ($self->roots) {
        $self->plot($target, gv => $gv);
    }
    $gv;
}

1;
__END__