File Coverage

blib/lib/Graphviz/DSL.pm

Criterion	Covered	Total	%
statement	134	141	95.0
branch	2	2	100.0
condition	0	4	0.0
subroutine	45	48	93.7
pod			n/a
total	181	195	92.8

package Graphviz::DSL;
use strict;
use warnings;
use 5.008_001;

use Carp ();
use Encode ();
use File::Which ();

use Graphviz::DSL::Graph;
use Graphviz::DSL::Edge;
use Graphviz::DSL::Node;

our $VERSION = '0.03';

sub import {
    my $class = shift;
    my $pkg   = caller;

    no strict   'refs';
    no warnings 'redefine';

    *{"$pkg\::graph"}    = _build_graph();
    *{"$pkg\::add"}      = sub { goto &add      };
    *{"$pkg\::route"}    = sub { goto &route    };
    *{"$pkg\::node"}     = sub { goto &node     };
    *{"$pkg\::edge"}     = sub { goto &edge     };
    *{"$pkg\::nodes"}    = sub { goto &nodes    };
    *{"$pkg\::edges"}    = sub { goto &edges    };
    *{"$pkg\::nodeset"}  = sub { goto &nodeset  };
    *{"$pkg\::edgeset"}  = sub { goto &edgeset  };
    *{"$pkg\::global"}   = sub { goto &global   };
    *{"$pkg\::rank"}     = sub { goto &rank     };
    *{"$pkg\::name"}     = sub { goto &name     };
    *{"$pkg\::type"}     = sub { goto &type     };
    *{"$pkg\::subgraph"} = (sub { sub (&) { goto &subgraph } })->();
    *{"$pkg\::multi_route"} = sub { goto &multi_route };
}

sub _new {
    my ($class, %args) = @_;

    my $name = delete $args{name} || 'G';
    my $type = delete $args{type} || 'digraph';

    bless {
        name        => $name,
        type        => $type,
        edges       => [],
        nodes       => [],
        gnode_attrs => [],
        gedge_attrs => [],
        graph_attrs => [],
        subgraphs   => [],
        ranks       => [],
        objects     => [],
    }, $class;
}

sub _build_nodes {
    my $self = shift;

    sub {
        $self->_nodes;
    };
}

sub _build_graph {
    my ($subgraph) = @_;

    sub (&) {
        my $code = shift;

        my $graph = defined $subgraph ? $subgraph : Graphviz::DSL::Graph->new();

        no warnings 'redefine';

        my $add_code = sub { $graph->add(@_) };

        local *add      = \&$add_code;
        local *route    = \&$add_code;
        local *node     = sub { $graph->node(@_) };
        local *edge     = sub { $graph->edge(@_) };
        local *nodes    = sub { $graph->update_attrs('gnode_attrs', @_) };
        local *edges    = sub { $graph->update_attrs('gedge_attrs', @_) };
        local *nodeset  = sub { @{$graph->{nodes}} };
        local *edgeset  = sub { @{$graph->{edges}} };
        local *global   = sub { $graph->update_attrs('graph_attrs', @_) };
        local *rank     = sub { $graph->rank(@_) };
        local *name     = sub { $graph->name(@_) };
        local *type     = sub { $graph->type(@_) };
        local *subgraph = _build_subgraph($graph);
        local *multi_route = sub { $graph->multi_route(@_) };

        local $Carp::CarpLevel = $Carp::CarpLevel + 1;

        $code->();
        $graph;
    }
}

sub _build_subgraph {
    my $parent = shift;

    sub (&) {
        my $code = shift;
        my $num  = scalar @{$parent->{subgraphs}};

        my $self = Graphviz::DSL::Graph->new(
            id       => "cluster${num}",
            type     => $parent->{type},
            subgraph => 1,
        );
        my $graph = _build_graph($self);

        my $subgraph = $graph->($code);
        push @{$parent->{subgraphs}}, $subgraph;
        push @{$parent->{objects}}, $subgraph;
    };
}

sub __stub {
    my $func = shift;
    return sub {
        Carp::croak "Can't call $func() outside graph block";
    };
}

*route    = __stub 'route';
*add      = __stub 'add';
*node     = __stub 'node';
*edge     = __stub 'edge';
*nodes    = __stub 'nodes';
*edges    = __stub 'edges';
*nodeset  = __stub 'nodeset';
*edgeset  = __stub 'edgeset';
*global   = __stub 'global';
*rank     = __stub 'rank';
*subgraph = __stub 'subgraph';
*name     = __stub 'name';
*type     = __stub 'type';
*multi_route = __stub 'multi_route';

1;

__END__