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 => sub {
                '(' . join('|',  map { s{lib/}{}; $_ } sort grep { -d $_ } glob("lib/*") ) . ')'
        },
);


has filter_class => (
        is => 'rw',
        isa => 'Bool',
        default => 1,
);

has filter_extends => (
        is => 'rw',
        isa => 'Bool',
        default => 1,
);

has filter_includes => (
        is => 'rw',
        isa => 'Bool',
        default => 1,
);

has filter_roles => (
        is => 'rw',
        isa => 'Bool',
        default => 1,
);


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 show_disconnected => (
        is => 'ro',
        isa => 'Bool',
);


has layout => (
        documentation => 'layout algorithm',
        is => 'rw',
        isa => 'Str',
        required => 1,
);

sub layout_available { q/
dot             directed graph
neato   spring model
twopi   radial
circo   circular
fdp             force directed spring model
/ }

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

has no_overlap => (
        documentation => 'avoid overlaping nodes',
        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 => $self->layout,
#               layout => 'neato', # grabs too much memory
#               layout => 'twopi', # grabs too much memory
#               overlap => 'compress',
                no_overlap => $self->no_overlap,

                node => {
                        shape => 'box',
                        style =>'filled',
                        color => 'grey',
                        fillcolor =>'lightgray',
                        fontname  => 'verdana',
                        fontsize  => '12',

                },
                edge => {
                        color => 'grey',
                        fontname  => 'verdana',
                        fontsize  => '8',
                        fontcolor => 'grey',
                }
        );

        my $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";

                $count->{$class}++ if $self->show_disconnected;

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

                next if $filter && $self->filter_class && $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 && $self->filter_includes && $package !~ m{$filter};
                                        warn "# $class\t$type\t$package\n";
                                        $g->add_edge( $class => $package, label => $type, color => 'blue' );
                                        $count->{$class}++;
                                        $count->{$package}++;
                                }
                        }
                }

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

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

        }

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

        my $max_count = 1;
        foreach ( keys %$count ) {
                my $v = $count->{$_};
                $max_count = $v if $v > $max_count;
        }
        warn "# max_count: $max_count";

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

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

        }

        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	982	default => sub {
17			'(' . join('\|', map { s{lib/}{}; $_ } sort grep { -d $_ } glob("lib/*") ) . ')'
18			},
19	dpavlin	972	);
20
21	dpavlin	982
22			has filter_class => (
23			is => 'rw',
24			isa => 'Bool',
25			default => 1,
26			);
27
28			has filter_extends => (
29			is => 'rw',
30			isa => 'Bool',
31			default => 1,
32			);
33
34			has filter_includes => (
35			is => 'rw',
36			isa => 'Bool',
37			default => 1,
38			);
39
40			has filter_roles => (
41			is => 'rw',
42			isa => 'Bool',
43			default => 1,
44			);
45
46
47	dpavlin	977	has show_extends => (
48			documentation => 'connect to superclasses',
49	dpavlin	972	is => 'rw',
50	dpavlin	977	isa => 'Bool',
51	dpavlin	970	);
52
53	dpavlin	977	has show_includes => (
54			documentation => 'use and require connections',
55			is => 'rw',
56			isa => 'Bool',
57			default => 1,
58			);
59
60			has show_roles => (
61			documentation => 'roles consumers connections',
62			is => 'rw',
63			isa => 'Bool',
64			);
65
66	dpavlin	981	has show_disconnected => (
67			is => 'ro',
68			isa => 'Bool',
69			);
70
71	dpavlin	982
72	dpavlin	1079	has layout => (
73			documentation => 'layout algorithm',
74			is => 'rw',
75			isa => 'Str',
76			required => 1,
77			);
78
79			sub layout_available { q/
80			dot directed graph
81			neato spring model
82			twopi radial
83			circo circular
84			fdp force directed spring model
85			/ }
86
87	dpavlin	977	has portrait => (
88			documentation => 'vertical layout',
89			is => 'rw',
90			isa => 'Bool',
91			);
92
93	dpavlin	1080	has no_overlap => (
94			documentation => 'avoid overlaping nodes',
95			is => 'rw',
96			isa => 'Bool',
97			);
98
99	dpavlin	972	has produce_dot => (
100	dpavlin	977	documentation => 'dump .dot text format',
101	dpavlin	972	is => 'rw',
102			isa => 'Bool',
103			);
104
105	dpavlin	977	sub introspect_path { 'var/introspect/' };
106
107	dpavlin	970	sub as_markup {
108			my ($self) = @_;
109
110	dpavlin	977	my $rankdir = $self->portrait;
111
112	dpavlin	972	my $g = GraphViz->new(
113	dpavlin	977	rankdir => $rankdir,
114	dpavlin	1079	layout => $self->layout,
115	dpavlin	972	# layout => 'neato', # grabs too much memory
116			# layout => 'twopi', # grabs too much memory
117			# overlap => 'compress',
118	dpavlin	1080	no_overlap => $self->no_overlap,
119	dpavlin	981
120	dpavlin	977	node => {
121			shape => 'box',
122	dpavlin	981	style =>'filled',
123			color => 'grey',
124			fillcolor =>'lightgray',
125			fontname => 'verdana',
126			fontsize => '12',
127
128	dpavlin	977	},
129			edge => {
130			color => 'grey',
131	dpavlin	981	fontname => 'verdana',
132			fontsize => '8',
133			fontcolor => 'grey',
134	dpavlin	977	}
135	dpavlin	972	);
136	dpavlin	970
137	dpavlin	981	my $count;
138	dpavlin	972	my $filter = $self->filter;
139	dpavlin	970
140	dpavlin	977	foreach my $path ( $self->dir_extension( $self->introspect_path, qr{\.(ya?ml)$}) ) {
141	dpavlin	970
142	dpavlin	972	my $class = $self->strip_path_extension( $path ) \|\| die "can't strip $path";
143	dpavlin	977
144	dpavlin	981	$count->{$class}++ if $self->show_disconnected;
145
146	dpavlin	972	my $data = $self->load( $path );
147			# warn "## $class $path ", $self->dump( $data ); # if $self->debug;
148
149	dpavlin	982	next if $filter && $self->filter_class && $class !~ m{$filter};
150	dpavlin	972
151	dpavlin	977	if ( $self->show_includes && defined $data->{includes} ) {
152			foreach my $type ( keys %{ $data->{includes} } ) {
153			foreach my $package ( @{ $data->{includes}->{$type} } ) {
154	dpavlin	982	next if $filter && $self->filter_includes && $package !~ m{$filter};
155	dpavlin	977	warn "# $class\t$type\t$package\n";
156			$g->add_edge( $class => $package, label => $type, color => 'blue' );
157	dpavlin	981	$count->{$class}++;
158			$count->{$package}++;
159	dpavlin	972	}
160			}
161			}
162
163	dpavlin	977	if ( $self->show_roles && defined $data->{roles} ) {
164			foreach my $role ( keys %{ $data->{roles} } ) {
165	dpavlin	982	next if $filter && $self->filter_roles && $role !~ m{$filter};
166	dpavlin	977	warn "# $class\trole\t$role\n";
167	dpavlin	1099	$g->add_edge( $role => $class, label => 'with', color => 'yellow' );
168			$g->add_node( $role, shape => 'diamond' );
169	dpavlin	981	$count->{$class}++;
170			$count->{$role}++;
171	dpavlin	977	}
172			}
173	dpavlin	974
174	dpavlin	977	if ( $self->show_extends && defined $data->{superclass} ) {
175			foreach my $extends ( keys %{ $data->{superclass} } ) {
176	dpavlin	982	next if $filter && $self->filter_extends && $extends !~ m{$filter};
177	dpavlin	977	warn "# $class\textends\t$extends\n";
178			$g->add_edge( $extends => $class, label => 'extends', color => 'green' );
179	dpavlin	981	$count->{$class}++;
180			$count->{$extends}++;
181	dpavlin	977	}
182	dpavlin	974	}
183
184	dpavlin	972	}
185
186			warn "# count ",$self->dump( $count );
187
188	dpavlin	981	my $max_count = 1;
189			foreach ( keys %$count ) {
190			my $v = $count->{$_};
191			$max_count = $v if $v > $max_count;
192			}
193			warn "# max_count: $max_count";
194
195	dpavlin	977	foreach my $node ( keys %$count ) {
196	dpavlin	981	my $v = $count->{$node};
197			my $pcnt = $v / $max_count;
198			my $color = join(",", ( $pcnt, $pcnt, 0.75 ) );
199	dpavlin	972
200	dpavlin	977	$g->add_node( $node,
201			style =>'filled',
202			color => $color,
203			fillcolor => $color,
204	dpavlin	981	# label => "$node\n$v",
205	dpavlin	977	);
206
207			}
208
209	dpavlin	972	if ( $self->produce_dot ) {
210			$self->content_type( 'text/plain' );
211	dpavlin	974	$self->store( 'var/classes.dot', $g->as_canon );
212	dpavlin	972	return $g->as_canon;
213			}
214
215	dpavlin	970	$self->content_type( 'image/png' );
216			return $g->as_png;
217	dpavlin	972
218	dpavlin	970	}
219
220			1;