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 GraphViz;
use base 'Makefile::Parser';

$VERSION = '0.21';

$Makefile::Parser::Strict = 0;

our $IDCounter = 0;

# ================================
# == Default values & functions ==
# ================================

my %NormalNodeStyle = (
    shape     => 'box',
    style     => 'filled',
    fillcolor => '#ffff99',
    fontname  => 'Arial',
    fontsize  => 10,
);

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

my %NormalEndNodeStyle = (
    fillcolor => '#ccff99'
);

my %VirEndNodeStyle = (
    shape     => 'plaintext',
    fillcolor => '#ccff99'
);

my %CmdStyle = (
    shape     => 'note',
    style     => 'filled',
    fillcolor => '#dddddd',
    fontname  => 'Monospace',
    fontsize  => 8,
);

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

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

our %Nodes;

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

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

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

sub _url ($) {
    my $url = shift;
    $url =~ s/[\/\\:. \t]+/_/g;
    return $url;
}

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

# Plot graph with single root target
sub plot ($$@) {

    # ==================================
    # == Unnamed command line options ==
    # ==================================

    # Self
    my $self = shift;

    # Main/root target
    my $root_name = shift;

    # ================================
    # == Named command line options ==
    # ================================

    my %opts = @_;
    my $gv = $opts{gv};

    # Helper function for initialising undefined user options with defaults
    my $init_opts = sub {
        my $key = shift;
        $opts{$key} = +shift unless $opts{$key} and ref $opts{$key};
    };

    $init_opts->('init_args',             \%InitArgs);
    $init_opts->('normal_node_style',     \%NormalNodeStyle);
    $init_opts->('vir_node_style',        \%VirNodeStyle);
    $init_opts->('normal_end_node_style', \%NormalEndNodeStyle);
    $init_opts->('vir_end_node_style',    \%VirEndNodeStyle);
    $init_opts->('cmd_style',             \%CmdStyle);
    $init_opts->('edge_style',            \%EdgeStyle);
    $init_opts->('node_trim_fct',         \&_trim_path);
    $init_opts->('cmd_trim_fct',          \&_trim_cmd);
    $init_opts->('url_fct',               \&_url);

    $opts{init_args}{name} = qq("$root_name");
    $opts{init_args}{node} = $opts{normal_node_style};
    $opts{init_args}{edge} = \%{$opts{edge_style}};

    # =========================
    # == Initialise GraphViz ==
    # =========================

    # Do nothing if root node is in exclude list
    return $gv if _find($root_name, @{$opts{exclude}}) and !_find($root_name, @{$opts{no_exclude}});

    # Create new graph object if necessary
    if (!$gv) {
        $gv = GraphViz->new(%{$opts{init_args}});
        %Nodes = ();
    }

    # ===========================================
    # == Create graph, starting from root node ==
    # ===========================================

    # Assume we have a normal node
    my $is_virtual = 0;
    # Do nothing if node has already been processed
    if ($Nodes{$root_name}) {
        return $gv;
    }
    # Add node to processed node list
    $Nodes{$root_name} = 1;

    # Initialise root node list
    my @roots = ($root_name and ref $root_name)
        ? $root_name
        : ($self->target($root_name));

    # INFO: Why a list? Because multiple definitions of the same target with
    # different prerequisites and recipes (commands) can occur. In this case
    # $self->target returns multiple target objects with the same name, but
    # different properties. Run the test suite and uncomment the code below
    # to see this happen.
    #if (scalar(@roots) > 1) {
    #    warn "\n\@roots contains multiple entries\n" ;
    #    if ($root_name and ref $root_name) {
    #        warn "  \$root_name is a reference\n" ;
    #    }
    #    else {
    #        warn "  \$self->target(\$root_name) delivers >1 targets\n" ;
    #        for my $root (@roots) {
    #            my @p = $root->prereqs();
    #            my @c = $root->commands();
    #            warn "    root = $root  ->  prereqs = @p  /  commands = @c\n";
    #        }
    #    }
    #}

    # Trim node name
    my $short_name = $opts{node_trim_fct}->($root_name);

    # Determine node type (normal or virtual)
    if (_find($root_name, @{$opts{normal_nodes}})) {
        # Node is member of normal nodes list -> normal
        $is_virtual = 0;
    } elsif (_find($root_name, @{$opts{vir_nodes}}) or @roots and !$roots[0]->commands) {
        # Node is member of virtual nodes list or has no commands -> virtual
        $is_virtual = 1;
    }

    # Is there a make target for this node?
    if (!@roots) {
        # No -> node is a "tree leave" -> add node, then stop processing
        $gv->add_node(
            $root_name,
            label       => $short_name,
            $is_virtual ? %{$opts{vir_node_style}} : ()
        );
        return $gv;
    }

    # Loop through node list for current target
    for my $root (@roots) {
        # Get prerequisites
        my @prereqs = $root->prereqs;
        # Is target flagged to be an end node?
        my $is_end_node = (_find($root_name, @{$opts{end_with}}) and !_find($root_name, @{$opts{no_end_with}})) ? 1 : 0;

        # Expandable end node (i.e. with prerequisites)?
        if ($is_end_node and @prereqs) {
            # Yes -> add end node with URL
            $gv->add_node(
                $root_name,
                label       => $short_name,
                # Add URL because the user might want to create a set of interlinked
                # graphs with each end node pointing to its sub-graph
                URL         => $opts{url_fct}->($root_name),
                $is_virtual ? %{$opts{vir_end_node_style}} : %{$opts{normal_end_node_style}}
            );
            # Call user-defined hook in case she wants to do something with end nodes,
            # such as collect their names and then recursively plot sub-graphs.
            $opts{end_with_callback}->($root_name) if $opts{end_with_callback};
            # Stop processing here (thus the name "end node")
            #return $gv;
        }
        else {
            # No-> ordinary node or end node without prerequisites -> add normal node
            $gv->add_node(
                $root_name,
                label       => $short_name,
                $is_virtual ? %{$opts{vir_node_style}} : ()
            );
        }

        # Add command node displaying target's recipe if trim_mode is false
        # and recipe exists. BTW, '\l' left-justifies each single line.
        my $lower_node;
        my @cmds = $root->commands;
        if (!$opts{trim_mode} and @cmds) {
            # Command node gets an auto-created ID as its name
            $lower_node = _gen_id();
            my $cmds = join("\\l", map { $opts{cmd_trim_fct}->($_); } @cmds);
            $gv->add_node(
                $lower_node,
                label       => $cmds . "\\l",
                %{$opts{cmd_style}}
            );
            # The recipe points to its target (dashed line if virtual target)
            $gv->add_edge(
                $lower_node => $root_name,
                $is_virtual ? (style => 'dashed') : ()
            );
        } else {
            $lower_node = $root_name;
        }

        # No further processing for end nodes
        next if $is_end_node;

        # Check prerequisites
        foreach (@prereqs) {
            # Ignore prerequisites on exclude list or named "|"
            next if $_ eq "|" or (_find($_, @{$opts{exclude}}) and !_find($_, @{$opts{no_exclude}}));
            # The prerequisite points to its dependent target (dashed line if virtual target)
            $gv->add_edge(
                $_          => $lower_node,
                $is_virtual ? (style => 'dashed') : ());
            # Recurse into 'plot' for prerequisite
            $self->plot($_, gv => $gv, @_);
        }
    }
    return $gv;
}

# Plot graph with multiple (all) root targets
sub plot_all ($) {
    my $self = shift;
    # TODO: Should we not also apply $opts{init_args} here?
    my $gv = GraphViz->new(%InitArgs);
    %Nodes = ();
    for my $target ($self->roots) {
        $self->plot($target, gv => $gv);
    }
    $gv;
}

1;
__END__