Frey/Class/Graph.pm

package Frey::Class::Graph;
use Moose;

extends 'Frey';
with 'Frey::Web';
with 'Frey::File';
with 'Frey::Storage';

use GraphViz;

has filter => (
        documentation => 'Regex to select classes',
        is => 'rw',
        isa => 'Str',
        required => 1,
        default => 'Frey',
);

has show_extends => (
        documentation => 'connect to superclasses',
        is => 'rw',
        isa => 'Bool',
);

has show_includes => (
        documentation => 'use and require connections',
        is => 'rw',
        isa => 'Bool',
        default => 1,
);

has show_roles => (
        documentation => 'roles consumers connections',
        is => 'rw',
        isa => 'Bool',
);

has portrait => (
        documentation => 'vertical layout',
        is => 'rw',
        isa => 'Bool',
);

has produce_dot => (
        documentation => 'dump .dot text format',
        is => 'rw',
        isa => 'Bool',
);

sub introspect_path { 'var/introspect/' };

sub as_markup {
        my ($self) = @_;

        my $rankdir = $self->portrait;

        my $g = GraphViz->new(
                rankdir => $rankdir,
#               layout => 'neato', # grabs too much memory
#               layout => 'twopi', # grabs too much memory
#               overlap => 'compress',
#               no_overlap => 1,
                node => {
                        shape => 'box',
#                       style =>'filled',
#                       color => 'grey',
#                       fillcolor =>'lightgray',
                },
                edge => {
                        color => 'grey',
                }
        );

        our $count = {};
        our $max_count = {};
        my $filter = $self->filter;

        foreach my $path ( $self->dir_extension( $self->introspect_path, qr{\.(ya?ml)$}) ) {

                my $class = $self->strip_path_extension( $path ) || die "can't strip $path";
                $max_count->{$class} = ++$count->{$class};

                my $data = $self->load( $path );
#               warn "## $class $path ", $self->dump( $data ); # if $self->debug;

                next if $filter && $class !~ m{$filter};

                if ( $self->show_includes && defined $data->{includes} ) {
                        foreach my $type ( keys %{ $data->{includes} } ) {
                                foreach my $package ( @{ $data->{includes}->{$type} } ) {
                                        next if $filter && $package !~ m{$filter};
                                        warn "# $class\t$type\t$package\n";
                                        $g->add_edge( $class => $package, label => $type, color => 'blue' );
                                        $max_count->{$package} = ++$count->{$package};
                                }
                        }
                }

                if ( $self->show_roles && defined $data->{roles} ) {
                        foreach my $role ( keys %{ $data->{roles} } ) {
                                next if $filter && $role !~ m{$filter};
                                warn "# $class\trole\t$role\n";
                                $g->add_edge( $role => $class, label => 'role', color => 'yellow' );
#                               $g->add_node( $role, rank => 'role' );
                                $max_count->{$role} = ++$count->{$role};
                        }
                }

                if ( $self->show_extends && defined $data->{superclass} ) {
                        foreach my $extends ( keys %{ $data->{superclass} } ) {
                                next if $filter && $extends !~ m{$filter};
                                warn "# $class\textends\t$extends\n";
                                $g->add_edge( $extends => $class, label => 'extends', color => 'green' );
                                $max_count->{$extends} = ++$count->{$extends};
                        }
                }

        }

=for xxx
        warn "# count ",$self->dump( $count );

        foreach my $node ( keys %$count ) {
                my $pcnt = $count->{$node} / $max_count->{$node};
                my $color = join(",", ( $pcnt, 0.5, 0.75 ) );

                $g->add_node( $node, 
                        style =>'filled',
                        color => $color,
                        fillcolor => $color,
                        label => "$node\n$pcnt",
                );

        }
=cut

        if ( $self->produce_dot ) {
                $self->content_type( 'text/plain' );
                $self->store( 'var/classes.dot', $g->as_canon );
                return $g->as_canon;
        }

        $self->content_type( 'image/png' );
        return $g->as_png;

}

1;
1	dpavlin	970	package Frey::Class::Graph;
2			use Moose;
3
4			extends 'Frey';
5			with 'Frey::Web';
6	dpavlin	972	with 'Frey::File';
7			with 'Frey::Storage';
8	dpavlin	970
9			use GraphViz;
10
11	dpavlin	972	has filter => (
12			documentation => 'Regex to select classes',
13	dpavlin	970	is => 'rw',
14			isa => 'Str',
15	dpavlin	977	required => 1,
16	dpavlin	972	default => 'Frey',
17			);
18
19	dpavlin	977	has show_extends => (
20			documentation => 'connect to superclasses',
21	dpavlin	972	is => 'rw',
22	dpavlin	977	isa => 'Bool',
23	dpavlin	970	);
24
25	dpavlin	977	has show_includes => (
26			documentation => 'use and require connections',
27			is => 'rw',
28			isa => 'Bool',
29			default => 1,
30			);
31
32			has show_roles => (
33			documentation => 'roles consumers connections',
34			is => 'rw',
35			isa => 'Bool',
36			);
37
38			has portrait => (
39			documentation => 'vertical layout',
40			is => 'rw',
41			isa => 'Bool',
42			);
43
44	dpavlin	972	has produce_dot => (
45	dpavlin	977	documentation => 'dump .dot text format',
46	dpavlin	972	is => 'rw',
47			isa => 'Bool',
48			);
49
50	dpavlin	977	sub introspect_path { 'var/introspect/' };
51
52	dpavlin	970	sub as_markup {
53			my ($self) = @_;
54
55	dpavlin	977	my $rankdir = $self->portrait;
56
57	dpavlin	972	my $g = GraphViz->new(
58	dpavlin	977	rankdir => $rankdir,
59	dpavlin	972	# layout => 'neato', # grabs too much memory
60			# layout => 'twopi', # grabs too much memory
61			# overlap => 'compress',
62			# no_overlap => 1,
63	dpavlin	977	node => {
64			shape => 'box',
65			# style =>'filled',
66			# color => 'grey',
67			# fillcolor =>'lightgray',
68			},
69			edge => {
70			color => 'grey',
71			}
72	dpavlin	972	);
73	dpavlin	970
74	dpavlin	972	our $count = {};
75	dpavlin	977	our $max_count = {};
76	dpavlin	972	my $filter = $self->filter;
77	dpavlin	970
78	dpavlin	977	foreach my $path ( $self->dir_extension( $self->introspect_path, qr{\.(ya?ml)$}) ) {
79	dpavlin	970
80	dpavlin	972	my $class = $self->strip_path_extension( $path ) \|\| die "can't strip $path";
81	dpavlin	977	$max_count->{$class} = ++$count->{$class};
82
83	dpavlin	972	my $data = $self->load( $path );
84			# warn "## $class $path ", $self->dump( $data ); # if $self->debug;
85
86			next if $filter && $class !~ m{$filter};
87
88	dpavlin	977	if ( $self->show_includes && defined $data->{includes} ) {
89			foreach my $type ( keys %{ $data->{includes} } ) {
90			foreach my $package ( @{ $data->{includes}->{$type} } ) {
91	dpavlin	972	next if $filter && $package !~ m{$filter};
92	dpavlin	977	warn "# $class\t$type\t$package\n";
93			$g->add_edge( $class => $package, label => $type, color => 'blue' );
94			$max_count->{$package} = ++$count->{$package};
95	dpavlin	972	}
96			}
97			}
98
99	dpavlin	977	if ( $self->show_roles && defined $data->{roles} ) {
100			foreach my $role ( keys %{ $data->{roles} } ) {
101			next if $filter && $role !~ m{$filter};
102			warn "# $class\trole\t$role\n";
103			$g->add_edge( $role => $class, label => 'role', color => 'yellow' );
104			# $g->add_node( $role, rank => 'role' );
105			$max_count->{$role} = ++$count->{$role};
106			}
107			}
108	dpavlin	974
109	dpavlin	977	if ( $self->show_extends && defined $data->{superclass} ) {
110			foreach my $extends ( keys %{ $data->{superclass} } ) {
111			next if $filter && $extends !~ m{$filter};
112			warn "# $class\textends\t$extends\n";
113			$g->add_edge( $extends => $class, label => 'extends', color => 'green' );
114			$max_count->{$extends} = ++$count->{$extends};
115			}
116	dpavlin	974	}
117
118	dpavlin	972	}
119
120	dpavlin	977	=for xxx
121	dpavlin	972	warn "# count ",$self->dump( $count );
122
123	dpavlin	977	foreach my $node ( keys %$count ) {
124			my $pcnt = $count->{$node} / $max_count->{$node};
125			my $color = join(",", ( $pcnt, 0.5, 0.75 ) );
126	dpavlin	972
127	dpavlin	977	$g->add_node( $node,
128			style =>'filled',
129			color => $color,
130			fillcolor => $color,
131			label => "$node\n$pcnt",
132			);
133
134			}
135			=cut
136
137	dpavlin	972	if ( $self->produce_dot ) {
138			$self->content_type( 'text/plain' );
139	dpavlin	974	$self->store( 'var/classes.dot', $g->as_canon );
140	dpavlin	972	return $g->as_canon;
141			}
142
143	dpavlin	970	$self->content_type( 'image/png' );
144			return $g->as_png;
145	dpavlin	972
146	dpavlin	970	}
147
148			1;